File: build/expression.ml (return to index)



Statistics:  
kind coverage
binding 11 / 11 (100 %)
sequence 8 / 8 (100 %)
for 0 / 0 (- %)
if/then 4 / 4 (100 %)
try 1 / 1 (100 %)
while 0 / 0 (- %)
match/function 107 / 144 (74 %)
kind coverage
class expression 0 / 0 (- %)
class initializer 0 / 0 (- %)
class method 0 / 0 (- %)
class value 0 / 0 (- %)
toplevel expression 0 / 0 (- %)
lazy operator 12 / 12 (100 %)



Source:

fold all unfold all
000001| (**
000002| This program is free software; you can redistribute it and / or modify
000003| it under the terms of the GNU General Public License as published by
000004| the Free Software Foundation; version 3 of the License.
000005|  
000006| This program is distributed in the hope that it will be useful,
000007| but WITHOUT ANY WARRANTY; without even the implied warranty of
000008| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
000009| GNU General Public License for more details.
000010|  
000011| Evaluation of binary operations and comparaison of values
000012| Various helper functions for expression evaluation
000013|  
000014| @author Tony BenBrahim < tony.benbrahim at gmail.com >
000015|  
000016| *)
000017|  
000018| open Ast
000019| open RuntimeError
000020|  
000021| (**
000022| Converts a MapValue array to a list of values
000023| @param arr array
000024| @return a list of values
000025| *)
000026| let list_of_array arr =
000027|         match arr with
000028|         | RMapValue(h, ArraySubtype) -> (
000029|                                 match Hashtbl.find h "length" with
000030|                                 | RIntegerValue(0) ->(*[38]*)[]
000031|                                 | RIntegerValue(len) ->
000032|                                                 (*[772]*)let rec loop lst ind =
000033|                                                         ((*[1950]*)let lst = (Hashtbl.find h (string_of_int ind)):: lst in
000034|                                                                 (*[1950]*)if ind = 0 then (*[772]*)lst else ((*[1178]*)loop lst (ind - 1)))
000035|                                                 in (*[772]*)loop [] (len - 1)
000036|                                 | _ -> (*[0]*)raise (RuntimeError.InternalError "inconsistent array/length not found")
000037|                         )
000038|         | _ -> (*[0]*)raise (RuntimeError.InternalError "inconsistent array/not an array")
000039|  
000040| (**
000041| Converts a value to a string
000042| @param value the value to convert
000043| @return a string representing the value
000044| *)
000045| let rec string_of_value = function
000046|         | RStringValue(s) -> (*[4182]*)s
000047|         | RIntegerValue(i) -> (*[142]*)string_of_int i
000048|         | RFloatValue(f) -> (*[6]*)string_of_float f
000049|         | RBooleanValue(b) -> (*[4]*)string_of_bool b
000050|         | RMapValue(t, ArraySubtype) as v ->
000051|                         (*[2]*)let lst = list_of_array v
000052|                         in (*[2]*)let rec loop s = function
000053|                                 | [] -> (*[2]*)s^"]"
000054|                                 | v::[] -> (*[2]*)loop (s^(string_of_value v)) []
000055|                                 | v:: tl -> (*[0]*)loop (s^(string_of_value v)^", ") tl
000056|                         in (*[2]*)loop "[" lst
000057|         | RMapValue(t, MapSubtype) ->
000058|                         (*[40]*)(Hashtbl.fold (fun prop v s ->
000059|                                                                 (*[102]*)s^prop^": "^(string_of_value v)^";") t "{")^"}"
000060|         | RFunctionValue(_, _, _, _, _, _, _)        | RLibraryFunction(_) -> (*[100]*)"function"
000061|         | RVoid -> (*[2]*)"void"
000062|         | RUndefined -> (*[0]*)"undefined"
000063|  
000064| (**
000065| enumeration of a value's possible types
000066| *)
000067| type valuetype =
000068|         | IntegerType
000069|         | FloatType
000070|         | BooleanType
000071|         | StringType
000072|         | FunctionType
000073|         | LibraryCallType
000074|         | MapType
000075|         | ArrayType
000076|         | VoidType
000077|         | NaNType
000078|         | UndefinedType
000079|  
000080| (**
000081| Returns a value's type
000082| @param a value
000083| @return the value's type
000084| *)
000085| let value_type = function
000086|         | RIntegerValue(_) -> (*[11546]*)IntegerType
000087|         | RFloatValue(_) -> (*[0]*)FloatType
000088|         | RBooleanValue(_) -> (*[592]*)BooleanType
000089|         | RStringValue(_) -> (*[100]*)StringType
000090|         | RFunctionValue(_, _, _, _, _, _, _) -> (*[0]*)FunctionType
000091|         | RLibraryFunction(_) -> (*[0]*)LibraryCallType
000092|         | RMapValue(_, MapSubtype) -> (*[4]*)MapType
000093|         | RMapValue(_, ArraySubtype _) -> (*[2]*)ArrayType
000094|         | RVoid -> (*[0]*)VoidType
000095|         | RUndefined -> (*[0]*)UndefinedType
000096|  
000097| (**
000098| returns a string name for a value's type
000099| @param value a value
000100| @return string name for the value's type
000101| *)
000102| let string_of_value_type = function
000103|         | RStringValue(s) -> (*[2]*)"string"
000104|         | RIntegerValue(i) -> (*[16]*)"integer"
000105|         | RFloatValue(f) -> (*[0]*)"float"
000106|         | RBooleanValue(b) -> (*[10]*)"boolean"
000107|         | RMapValue(_, ArraySubtype) ->(*[2]*)"array"
000108|         | RMapValue(_, MapSubtype) -> (*[0]*)"map"
000109|         | RFunctionValue(_, _, _, _, _, _, _)        | RLibraryFunction(_) -> (*[0]*)"function"
000110|         | RVoid -> (*[0]*)"void"
000111|         | RUndefined -> (*[0]*)"undefined"
000112|  
000113| (** type to hold the result of casting two values to the same type *)
000114| type cast_type =
000115|         | IntegerCast of int * int
000116|         | FloatCast of float * float
000117|         | StringCast of string * string
000118|         | BoolCast of bool * bool
000119|  
000120| let cast_to_integer value =
000121|         match value with
000122|         | RIntegerValue(i) -> (*[2022]*)i
000123|         | _ -> (*[0]*)raise (EInvalidCast (string_of_value_type value,"integer"))
000124|  
000125| let cast_to_float value =
000126|         match value with
000127|         | RFloatValue(f) -> (*[0]*)f
000128|         | RIntegerValue(i) -> (*[0]*)float_of_int i
000129|         | _ -> (*[0]*)raise (EInvalidCast (string_of_value_type value,"float"))
000130|  
000131| (**
000132| Evaluate the operation
000133| @param value1 the first value
000134| @param value2 the second value
000135| @param operator the operator
000136| @return the value that results from the operation
000137| *)
000138| let evaluate_op value1 value2 operator =
000139|         (*[6650]*)let string_of_operator = function
000140|                 | Plus -> (*[2]*)"+"
000141|                 | Minus -> (*[0]*)"-"
000142|                 | Times -> (*[0]*)"*"
000143|                 | Divide -> (*[0]*)"/"
000144|                 | Modulo -> (*[0]*)"%"
000145|                 | Or -> (*[0]*)"||"
000146|                 | And -> (*[2]*)"&&"
000147|         in (*[6650]*)let string_op s1 s2 =
000148|                 (match operator with
000149|                         | Plus -> (*[60]*)RStringValue(s1 ^ s2)
000150|                         | _ -> (*[0]*)raise (EInvalidOperation (string_of_operator operator,"string"))
000151|                 )
000152|         in (*[6650]*)let float_op f1 f2 = ((*[18]*)let f = (match operator with
000153|                                         | Plus -> (*[6]*)f1 +. f2
000154|                                         | Minus -> (*[4]*)f1 -. f2
000155|                                         | Times -> (*[2]*)f1 *. f2
000156|                                         | Divide -> (*[6]*)f1 /. f2
000157|                                         | _ -> (*[0]*)raise (EInvalidOperation (string_of_operator operator,"float"))) in
000158|                          (*[18]*)RFloatValue(f)
000159|                 )
000160|         in match (value1, value2) with
000161|         | (RIntegerValue(i1), RIntegerValue(i2)) ->
000162|                         (match operator with
000163|                                 | Plus -> (*[5744]*)RIntegerValue( i1 + i2 )
000164|                                 | Minus -> (*[26]*)RIntegerValue( i1 - i2)
000165|                                 | Times -> (*[12]*)RIntegerValue( i1 * i2)
000166|                                 | Divide -> (*[8]*)RIntegerValue( i1 / i2) 
000167|                                 | Modulo -> (*[404]*)RIntegerValue( i1 mod i2)
000168|                                 | _ -> (*[2]*)raise (EInvalidOperation (string_of_operator operator,"integer"))
000169|                         )
000170|         | (RBooleanValue(b1), RBooleanValue(b2)) ->
000171|                         (match operator with
000172|                                 | And -> (*[334]*)RBooleanValue((*[334]*)b1 && (*[334]*)b2)
000173|                                 | Or -> (*[38]*)RBooleanValue((*[38]*)b1 || (*[30]*)b2)
000174|                                 | _ -> (*[2]*)raise (EInvalidOperation (string_of_operator operator,"boolean"))
000175|                         )
000176|         | (RFloatValue(f1), RFloatValue(f2)) -> (*[8]*)float_op f1 f2
000177|         | (RFloatValue(f1), RIntegerValue(i2)) -> (*[6]*)float_op f1 (float_of_int i2)
000178|         | (RIntegerValue(i1), RFloatValue(f2)) -> (*[4]*)float_op (float_of_int i1) f2
000179|         | (RStringValue(s1), RStringValue(s2)) -> (*[56]*)string_op s1 s2
000180|         | (RStringValue(s1), v2) -> (*[2]*)string_op s1 (string_of_value v2)
000181|         | (v1, RStringValue(s2)) -> (*[2]*)string_op (string_of_value v1) s2
000182|         | (value1, value2) -> (*[2]*)raise (EIncompatibleTypes(string_of_value_type value1, string_of_value_type value2))
000183|  
000184| (**
000185| Implements comparaison of two values, according to the following semantics:
000186|  
000187| Value 1 type Value 2 type Operator Result
000188| -------------- -------------- ----------- -----------------------------------------------------------------------
000189| Integer Integer Any Comparison of integer values
000190| Float Float Any Comparison of float values
000191| Float Integer Any Comparison of float values
000192| String any type Float comparison of first value to second value,
000193| Integer with non string values converted to strings
000194| String
000195| Both types are Booleans,
000196| maps, arrays, functions,
000197| NaN or void == and != comparison of first value to second value,
000198| observing the semantics of equality described below.
000199| Different types not listed
000200| above == and != == always returns false != always returns true
000201|  
000202| @param v1 the first value to compare
000203| @param op the comparaison operator
000204| @param v2 the second value to compare
000205| @return a boolean value type
000206| *)
000207| let rec compare v1 op v2 =
000208|         match v1 with
000209|         | RIntegerValue(i1) ->
000210|                         (match v2 with
000211|                                 | RIntegerValue(i2) ->
000212|                                                 (match op with
000213|                                                         | Equal -> (*[750]*)RBooleanValue(i1 = i2)
000214|                                                         | NotEqual -> (*[2046]*)RBooleanValue(i1 <> i2)
000215|                                                         | LessThan -> (*[2462]*)RBooleanValue(i1 < i2)
000216|                                                         | LessThanEqual -> (*[6]*)RBooleanValue(i1 <= i2)
000217|                                                         | GreaterThan -> (*[2]*)RBooleanValue(i1 > i2)
000218|                                                         | GreaterThanEqual -> (*[48]*)RBooleanValue(i1 >= i2) )
000219|                                 | RFloatValue(f2) -> (*[16]*)compare (RFloatValue (float_of_int i1)) op v2
000220|                                 | RStringValue(s2) -> (*[16]*)compare (RStringValue (string_of_int i1)) op v2
000221|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000222|         | RStringValue(s1) ->
000223|                         (match v2 with
000224|                                 | RStringValue(s2) ->
000225|                                                 (match op with
000226|                                                         | Equal -> (*[184]*)RBooleanValue(s1 = s2)
000227|                                                         | NotEqual -> (*[324]*)RBooleanValue(s1 <> s2)
000228|                                                         | LessThan -> (*[10]*)RBooleanValue(s1 < s2)
000229|                                                         | LessThanEqual -> (*[20]*)RBooleanValue(s1 <= s2)
000230|                                                         | GreaterThan -> (*[10]*)RBooleanValue(s1 > s2)
000231|                                                         | GreaterThanEqual -> (*[20]*)RBooleanValue(s1 >= s2) )
000232|                                 | RIntegerValue(i2) -> (*[16]*)compare v1 op (RStringValue(string_of_int i2))
000233|                                 | RFloatValue(f2) -> (*[16]*)compare v1 op (RStringValue(string_of_float f2))
000234|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000235|         | RBooleanValue(b1) ->
000236|                         (match v2 with
000237|                                 | RBooleanValue(b2) -> (
000238|                                                         match op with
000239|                                                         | Equal -> (*[12]*)RBooleanValue(b1 = b2)
000240|                                                         | NotEqual -> (*[2]*)RBooleanValue(b1 <> b2)
000241|                                                         | _ -> (*[2]*)raise (EInvalidComparaison(opname op, string_of_value_type v1, string_of_value_type v2)) )
000242|                                 | _ -> (*[10]*)mismatched_compare v1 op v2 )
000243|         | RVoid ->
000244|                         (match v2 with
000245|                                 | RVoid -> (
000246|                                                         match op with
000247|                                                         | Equal -> (*[8]*)RBooleanValue(true)
000248|                                                         | NotEqual -> (*[2]*)RBooleanValue(false)
000249|                                                         | _ -> (*[0]*)raise (EInvalidComparaison(opname op, string_of_value_type v1, string_of_value_type v2)) )
000250|                                 | _ -> (*[4]*)mismatched_compare v1 op v2 )
000251|         | RFloatValue(f1) ->
000252|                         (match v2 with
000253|                                 | RFloatValue(f2) ->
000254|                                                 (match op with
000255|                                                         | Equal -> (*[32]*)RBooleanValue(f1 = f2)
000256|                                                         | NotEqual -> (*[6]*)RBooleanValue(f1 <> f2)
000257|                                                         | LessThan -> (*[6]*)RBooleanValue(f1 < f2)
000258|                                                         | LessThanEqual -> (*[12]*)RBooleanValue(f1 <= f2)
000259|                                                         | GreaterThan -> (*[6]*)RBooleanValue(f1 > f2)
000260|                                                         | GreaterThanEqual -> (*[12]*)RBooleanValue(f1 >= f2) )
000261|                                 | RIntegerValue(i2) -> (*[18]*)compare v1 op (RFloatValue (float_of_int i2))
000262|                                 | RStringValue(s2) -> (*[16]*)compare (RStringValue(string_of_float f1)) op v2
000263|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000264|         | RMapValue(h1, ArraySubtype) ->
000265|                         (match v2 with
000266|                                 | RMapValue(h2, ArraySubtype) -> (
000267|                                                         match op with
000268|                                                         | Equal -> (*[38]*)RBooleanValue(hashtbl_equal h1 h2)
000269|                                                         | NotEqual -> (*[6]*)RBooleanValue(not (hashtbl_equal h1 h2))
000270|                                                         | _ -> (*[0]*)raise (EInvalidComparaison(opname op,
000271|                                                                                                 string_of_value_type v1,
000272|                                                                                                 string_of_value_type v2)) )
000273|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000274|         | RMapValue(h1, MapSubtype) ->
000275|                         (match v2 with
000276|                                 | RMapValue(h2, MapSubtype) -> (
000277|                                                         match op with
000278|                                                         | Equal -> (*[14]*)RBooleanValue(hashtbl_equal h1 h2)
000279|                                                         | NotEqual -> (*[6]*)RBooleanValue(not (hashtbl_equal h1 h2))
000280|                                                         | _ -> (*[0]*)raise (EInvalidComparaison(opname op,
000281|                                                                                                 string_of_value_type v1,
000282|                                                                                                 string_of_value_type v2)) )
000283|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000284|         | RFunctionValue(size1, depth1, len1, varargs1, stmts1, clos1, inline1) ->
000285|                         (match v2 with
000286|                                 | RFunctionValue(size2, depth2, len2, varargs2, stmts2, clos2, inline2) -> (
000287|                                                         match op with
000288|                                                         | Equal -> (*[2]*)RBooleanValue((*[2]*)size1 = size2 && (*[2]*)stmts1 = stmts2)
000289|                                                         | NotEqual -> (*[6]*)RBooleanValue(not ((*[6]*)size1 = size2 && (*[6]*)stmts1 = stmts2))
000290|                                                         | _ -> (*[0]*)raise (EInvalidComparaison(opname op,
000291|                                                                                                 string_of_value_type v1,
000292|                                                                                                 string_of_value_type v2)) )
000293|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000294|         | RLibraryFunction(def1) ->
000295|                         (match v2 with
000296|                                 | RLibraryFunction(def2) ->
000297|                                                 ( match op with
000298|                                                         | Equal -> (*[2]*)RBooleanValue(def1 == def2)
000299|                                                         | NotEqual -> (*[6]*)RBooleanValue(not (def1 == def2))
000300|                                                         | _ -> (*[0]*)raise (EInvalidComparaison(opname op,
000301|                                                                                                 string_of_value_type v1,
000302|                                                                                                 string_of_value_type v2)) )
000303|                                 | _ -> (*[2]*)mismatched_compare v1 op v2 )
000304|         | RUndefined -> (*[0]*)raise (RuntimeError.InternalError "unexpected value in compare")
000305| and opname = function
000306|         | LessThan -> (*[0]*)"<"
000307|         | LessThanEqual -> (*[0]*)"<="
000308|         | Equal -> (*[0]*)"=="
000309|         | NotEqual ->(*[0]*)"!="
000310|         | GreaterThanEqual -> (*[0]*)">="
000311|         | GreaterThan -> (*[2]*)">"
000312| and hashtbl_equal h1 h2 =
000313|         (*[64]*)(Hashtbl.length h1) = (Hashtbl.length h2) &&
000314|         (*[64]*)try
000315|                 (*[64]*)Hashtbl.fold (fun k v init -> (*[232]*)init && (*[194]*)(compare (Hashtbl.find h2 k) Equal v) = RBooleanValue(true) ) h1 true
000316|         with
000317|         | Not_found -> (*[2]*)false
000318| and mismatched_compare v1 op v2 =
000319|         match op with
000320|         | Equal -> (*[6]*)RBooleanValue(false)
000321|         | NotEqual -> (*[22]*)RBooleanValue(true)
000322|         | _ -> (*[0]*)raise (EInvalidComparaison(opname op, string_of_value_type v1, string_of_value_type v2))
000323| (**
000324| Makes a stack frame from the supplied value list
000325| @param size size of stack frame
000326| @param vararg true if the last argument is a vararg, false otherwise
000327| @param value_list list of values to add to the stack frame
000328| @param this the value of this
000329| @return a stack frame (an array of values)
000330| *)
000331| and make_stackframe size numargs vararg value_list this =
000332|         (*[3842]*)let stackframe = Array.make (size + 1) RUndefined
000333|         in (*[3842]*)let rec loop_single_values = function
000334|                 | (0, _, rest) -> (*[3838]*)rest
000335|                 | (num_left, ind, value:: rest) ->
000336|                                 (*[2826]*)stackframe.(ind) <- value;
000337|                                 (*[2826]*)loop_single_values (num_left - 1, ind + 1, rest)
000338|                 | (num_left, ind,[]) -> (*[4]*)raise (EMismatchedFunctionArgs (numargs, List.length value_list))
000339|         in (*[3842]*)let rest = loop_single_values ((if vararg then (*[730]*)numargs - 1 else (*[3112]*)numargs), 1, value_list)
000340|         in ((match (rest, vararg) with
000341|                         | (list, true) ->        (*[730]*)stackframe.(numargs) <- array_of_value_list(list)
000342|                         | ([] , false) -> (*[3106]*)()
000343|                         | (_, false) ->
000344|                                         (*[2]*)raise (EMismatchedFunctionArgs (numargs, List.length value_list))));
000345|         (*[3836]*)stackframe.(0) <- this;
000346|         (*[3836]*)stackframe
000347| (**
000348| Creates an Array from a list of values
000349| @param value_list a list of values
000350| @return a MapValue with the array
000351| *)
000352| and array_of_value_list value_list =
000353|         (*[730]*)let rec loop = function
000354|                 | (_,[], h) -> (*[730]*)h
000355|                 | (ind, value:: rest, h) ->
000356|                                 (*[1560]*)Hashtbl.replace h (string_of_int ind) value;
000357|                                 (*[1560]*)loop (ind + 1, rest, h)
000358|         in (*[730]*)let length = List.length value_list
000359|         in (*[730]*)let h = Hashtbl.create (length + 1)
000360|         in (*[730]*)Hashtbl.replace h "length" (RIntegerValue(length));
000361|         (*[730]*)RMapValue(loop (0, value_list, h), ArraySubtype)

Legend:
   some code - line containing no point
   some code - line containing only visited points
   some code - line containing only unvisited points
   some code - line containing both visited and unvisited points