Statistics: |
|
|
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"))
000087| (*[0]*)raise (LibraryError "First parameter is not an array in call to Array.length")
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")))
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"))
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"