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



Statistics:  
kind coverage
binding 37 / 37 (100 %)
sequence 21 / 21 (100 %)
for 0 / 0 (- %)
if/then 4 / 6 (66 %)
try 1 / 1 (100 %)
while 0 / 0 (- %)
match/function 35 / 41 (85 %)
kind coverage
class expression 0 / 0 (- %)
class initializer 0 / 0 (- %)
class method 0 / 0 (- %)
class value 0 / 0 (- %)
toplevel expression 0 / 0 (- %)
lazy operator 0 / 2 (0 %)



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| Built in library implementation
000012|  
000013| @author Tony BenBrahim < tony.benbrahim at gmail.com >
000014|  
000015| *)
000016|  
000017| open Environment
000018| open Ast
000019| open Expression
000020| open RuntimeError
000021| open Unix
000022|  
000023| (**
000024| Entry point for library initialization
000025| @return a list of exported functions
000026| *)
000027| let initialize env =
000028|         (*[2]*)let this_array_map env =
000029|                 match env.stackframes.(0).(0) with
000030|                 | RMapValue(h, ArraySubtype) -> (*[36]*)h
000031|                 | _ -> (*[6]*)raise (InternalError "expected array for this")
000032|         in (*[2]*)let this_map_map env =
000033|                 match env.stackframes.(0).(0) with
000034|                 | RMapValue(h, MapSubtype) -> (*[30]*)h
000035|                 | _ -> (*[4]*)raise (InternalError "expected map for this")
000036|         in (*[2]*)let this_float env =
000037|                 match env.stackframes.(0).(0) with
000038|                 | RFloatValue(f) -> (*[4]*)f
000039|                 | _ -> (*[2]*)raise (InternalError "expected float for this")
000040|         in (*[2]*)let _ = Random.self_init()
000041|         in (*[2]*)let date_map = Hashtbl.create 2
000042|         in (*[2]*)let date_proto_map = Hashtbl.create 1
000043|         in (*[2]*)let _ = Hashtbl.replace date_map "prototype" (RMapValue(date_proto_map, MapSubtype))
000044|         in (*[2]*)let env = Environment.declare_variable_and_value env "Date" (RMapValue(date_map, MapSubtype))
000045|         in (*[2]*)let env = Environment.declare_variable_and_value env "Debug" (RMapValue(Hashtbl.create 10, MapSubtype))
000046|         in (*[2]*)let env = Environment.declare_variable_and_value env "System" (RMapValue(Hashtbl.create 10, MapSubtype))
000047|         in ((*[2]*)[
000048|                 {
000049|                         name = ["Array";"prototype";"push"];
000050|                         args = ["value"];
000051|                         num_args = 1;
000052|                         vararg = false;
000053|                         code = fun env ->
000054|                                                 (*[24]*)let value = env.stackframes.(0).(1)
000055|                                                 in (*[24]*)let array = this_array_map env
000056|                                                 in (*[22]*)let len = string_of_value (Hashtbl.find array "length") in
000057|                                                 (*[22]*)Hashtbl.replace array len value;
000058|                                                 (*[22]*)Hashtbl.replace array "length" (RIntegerValue((int_of_string len) + 1))
000059|                 };
000060|                 {
000061|                         name =["Array";"prototype";"pop"];
000062|                         args =[];
000063|                         num_args = 0;
000064|                         vararg = false;
000065|                         code = fun env ->
000066|                                                 (*[8]*)let hashtbl = this_array_map env
000067|                                                 in (*[6]*)let len = int_of_string (string_of_value (Hashtbl.find hashtbl "length")) in
000068|                                                 (*[6]*)if len = 0 then
000069|                                                         (*[2]*)raise (LibraryError "Error while attempting to pop an empty array in Array.pop")
000070|                                                 else
000071|                                                         (*[4]*)let result = Hashtbl.find hashtbl (string_of_int (len - 1)) in
000072|                                                         (*[4]*)Hashtbl.remove hashtbl (string_of_int (len - 1));
000073|                                                         (*[4]*)Hashtbl.replace hashtbl "length" (RIntegerValue(len - 1));
000074|                                                         (*[4]*)raise (CFReturn result)
000075|                 };
000076|                 {
000077|                         name = ["Array";"prototype";"length"];
000078|                         args =[];
000079|                         num_args = 0;
000080|                         vararg = false;
000081|                         code = fun env ->
000082|                                                 (*[10]*)let hashtbl = this_array_map env
000083|                                                 in (*[8]*)try (match Hashtbl.find hashtbl "length" with
000084|                                                                 | RIntegerValue(len) -> (*[8]*)raise (CFReturn(RIntegerValue(len)))
000085|                                                                 | _ -> (*[0]*)raise (LibraryError "First parameter is not an array in call to Array.length"))
000086|                                                 with Not_found ->
000087|                                                                 (*[0]*)raise (LibraryError "First parameter is not an array in call to Array.length")
000088|                 };
000089|                 {
000090|                         name =["Map";"prototype";"remove"];
000091|                         args =["key"];
000092|                         num_args = 1;
000093|                         vararg = false;
000094|                         code = fun env ->
000095|                                                 (*[2]*)let hashtbl = this_map_map env
000096|                                                 in (*[2]*)let key = string_of_value (env.stackframes.(0).(1))
000097|                                                 in (*[2]*)let _ = Hashtbl.remove hashtbl key
000098|                                                 in (*[2]*)()
000099|                 };
000100|                 {
000101|                         name =["Map";"prototype";"contains"];
000102|                         args =["key"];
000103|                         num_args = 1;
000104|                         vararg = false;
000105|                         code = fun env ->
000106|                                                 (*[26]*)let hashtbl = this_map_map env
000107|                                                 in (*[24]*)let key = string_of_value (env.stackframes.(0).(1))
000108|                                                 in (*[24]*)raise (CFReturn(RBooleanValue(Hashtbl.mem hashtbl key)))
000109|                 };
000110|                 {
000111|                         name =["Map";"prototype";"keys"];
000112|                         args =[];
000113|                         num_args = 0;
000114|                         vararg = false;
000115|                         code = fun env ->
000116|                                                 (*[6]*)let hashtbl = this_map_map env
000117|                                                 in (*[4]*)let result = Hashtbl.create 10
000118|                                                 in (*[4]*)let (_, cnt) = Hashtbl.fold (fun k _ (h, cnt) -> ((*[12]*)Hashtbl.add h (string_of_int cnt) (RStringValue k); (*[12]*)h, cnt + 1 )) hashtbl (result, 0)
000119|                                                 in (*[4]*)Hashtbl.replace result "length" (RIntegerValue cnt );
000120|                                                 (*[4]*)raise (CFReturn (RMapValue (result, ArraySubtype)))
000121|                 };
000122|                 {
000123|                         name =["Integer";"random"];
000124|                         args =["upperBound"];
000125|                         num_args = 1;
000126|                         vararg = false;
000127|                         code = fun env ->
000128|                                                 (*[2022]*)let upperBound =
000129|                                                         (try
000130|                                                                 (*[2022]*)cast_to_integer(env.stackframes.(0).(1))
000131|                                                         with
000132|                                                         | _ -> (*[0]*)raise (LibraryError("upperBound must an integer in call to Integer.random")))
000133|                                                 in
000134|                                                 (*[2022]*)raise (CFReturn(RIntegerValue(Random.int upperBound)))
000135|                 };
000136|                 {
000137|                         name =["Float";"prototype";"round"];
000138|                         args =[];
000139|                         num_args = 0;
000140|                         vararg = false;
000141|                         code = fun env ->
000142|                                                 (*[6]*)let f = this_float env
000143|                                                 in (*[4]*)raise (CFReturn (RIntegerValue(int_of_float(
000144|                                                                                                 let (frac, _) = modf f in ((*[4]*)if frac >= 0.5 then (*[2]*)ceil f else (*[2]*)floor f)))))
000145|                 };
000146|                 {
000147|                         name =["Date";"now"];
000148|                         args =[];
000149|                         num_args = 0;
000150|                         vararg = false;
000151|                         code = fun env ->
000152|                                                 (*[2]*)let t = (localtime (time())) in
000153|                                                 (*[2]*)let gmt_offset = (localtime (time())).tm_hour - (gmtime (time())).tm_hour in
000154|                                                 (*[2]*)let h = Hashtbl.create 10 in
000155|                                                 (*[2]*)Hashtbl.add h "prototype" (RMapValue(date_proto_map, MapSubtype));
000156|                                                 (*[2]*)Hashtbl.add h "second" (RIntegerValue(t.tm_sec));
000157|                                                 (*[2]*)Hashtbl.add h "minute" (RIntegerValue(t.tm_min));
000158|                                                 (*[2]*)Hashtbl.add h "hour" (RIntegerValue(t.tm_hour));
000159|                                                 (*[2]*)Hashtbl.add h "dayOfMonth" (RIntegerValue(t.tm_mday));
000160|                                                 (*[2]*)Hashtbl.add h "month" (RIntegerValue(t.tm_mon + 1));
000161|                                                 (*[2]*)Hashtbl.add h "year" (RIntegerValue(1900 + t.tm_year));
000162|                                                 (*[2]*)Hashtbl.add h "dayOfWeek" (RIntegerValue(t.tm_wday)); (* Sunday 0 *)
000163|                                                 (*[2]*)Hashtbl.add h "dayOfYear" (RIntegerValue(t.tm_yday));
000164|                                                 (*[2]*)Hashtbl.add h "dst" (RBooleanValue(t.tm_isdst));
000165|                                                 (*[2]*)Hashtbl.add h "gmtOffset" (RIntegerValue(gmt_offset));
000166|                                                 (*[2]*)raise(CFReturn(RMapValue(h, MapSubtype)))
000167|                 };
000168|                 {
000169|                         name =["System";"command"];
000170|                         args = ["command"];
000171|                         num_args = 1;
000172|                         vararg = false;
000173|                         code = fun env ->
000174|                                                 (*[6]*)let command = string_of_value (env.stackframes.(0).(1)) in
000175|                                                 (*[6]*)raise (CFReturn (RIntegerValue(Sys.command command)))
000176|                 };
000177|                 {
000178|                         name =["exit"];
000179|                         args =["exitcode"];
000180|                         num_args = 1;
000181|                         vararg = false;
000182|                         code = fun env ->
000183|                                                 match env.stackframes.(0).(1) with
000184|                                                 | RIntegerValue(c) -> (*[0]*)if (*[0]*)c >= 0 && (*[0]*)c <= 255 then (*[0]*)exit c else
000185|                                                                         (*[0]*)raise (LibraryError("exitcode must be an integer between 0 and 255 in call to exit"))
000186|                                                 | _ -> (*[0]*)raise (LibraryError("exitcode must be an integer in call to exit"))
000187|                 };
000188|                 {
000189|                         name =["Debug";"dumpSymbolTable"];
000190|                         args =[];
000191|                         num_args = 0;
000192|                         vararg = false;
000193|                         code = fun env ->
000194|                                                 (*[2]*)let rec loop = function
000195|                                                         | 0 -> (*[2]*)()
000196|                                                         | n ->
000197|                                                                         (*[48]*)let (uid, value) = env.heap.(n - 1)
000198|                                                                         in (*[48]*)let _ = print_string (env.gnames.(uid)^" = " ^(string_of_value value) ^ "\n")
000199|                                                                         in (*[48]*)loop (n - 1)
000200|                                                 in (*[2]*)loop (Array.length env.heap)
000201|                 };
000202|                 {
000203|                         name =["Function";"prototype";"apply"];
000204|                         args =["args..."];
000205|                         num_args = 1;
000206|                         vararg = true;
000207|                         code = fun env ->
000208|                                                 (*[24]*)let func = env.stackframes.(0).(0)
000209|                                                 in match func with
000210|                                                 | RFunctionValue(_, _, _, _, _, _,_) | RLibraryFunction(_) ->
000211|                                                                 (*[22]*)let args = list_of_array env.stackframes.(0).(1)
000212|                                                                 in (*[22]*)let this = List.hd args
000213|                                                                 in (*[22]*)let args = List.tl args
000214|                                                                 in (*[22]*)let (_, v) = Interpreter.run_function env args this func
000215|                                                                 in (*[6]*)raise (CFReturn v)
000216|                                                 | _ -> (*[2]*)raise (LibraryError "expected a function in first parameter of call to apply")
000217|                 };
000218|                 {
000219|                         name =["Debug";"dumpStackTrace"];
000220|                         args =[];
000221|                         num_args = 0;
000222|                         vararg = false;
000223|                         code = fun env ->
000224|                                                 (*[2]*)Stack.iter (fun loc ->
000225|                                                                                 (*[8]*)let (file, line) = loc
000226|                                                                                 in (*[8]*)print_string ("Called from line "^(string_of_int line)^" in file "^ (Filename.basename file)^":\n"))
000227|                                                         env.callstack
000228|                 };
000229|                 {
000230|                         name = ["typeof"];
000231|                         args =["value"];
000232|                         num_args = 1;
000233|                         vararg = false;
000234|                         code = fun env ->
000235|                                                 (*[338]*)let s = match env.stackframes.(0).(1) with
000236|                                                         | RStringValue(_) -> (*[2]*)"string"
000237|                                                         | RIntegerValue(_) ->(*[20]*)"integer"
000238|                                                         | RFloatValue(_) -> (*[2]*)"float"
000239|                                                         | RBooleanValue(_) -> (*[300]*)"boolean"
000240|                                                         | RFunctionValue(_) | RLibraryFunction(_) -> (*[4]*)"function"
000241|                                                         | RMapValue(_, ArraySubtype) -> (*[6]*)"array"
000242|                                                         | RMapValue(_, MapSubtype) ->(*[2]*)"map"
000243|                                                         | RVoid ->(*[2]*)"void"
000244|                                                         | RUndefined -> (*[0]*)"undefined"
000245|                                                 in (*[338]*)raise (CFReturn (RStringValue s))
000246|                 };
000247|                 ], env)

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