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| I / O 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| exception EIOPassthrough of string
000024|
000025| type channelType = OutChannel of out_channel | InChannel of in_channel * (string * bool)
000026|
000027| (**
000028| Entry point for library initialization
000029| @return a list of exported functions
000030| *)
000031| let initialize env =
000032| (*[2]*)let env = Environment.declare_variable_and_value env "File" (RMapValue(Hashtbl.create 10, MapSubtype))
000033| in (*[2]*)let env = Environment.declare_variable_and_value env "Directory" (RMapValue(Hashtbl.create 10, MapSubtype))
000034| in (*[2]*)let descriptors = Hashtbl.create 10 in
000035| (*[2]*)let get_descriptor handle command =
000036| ((*[76]*)try
000037| (*[76]*)Hashtbl.find descriptors handle
000038| with
000039| | Not_found -> (*[0]*)raise (EIOPassthrough("invalid handle for "^command)))
000041| (
000042| (*[26]*)try
000043| ((*[26]*)input_line ch, false)
000044| with
000045| | End_of_file -> ((*[4]*)"", true)
000046| )
000047| in ((*[2]*)[
000048| {
000049| name = ["print"];
000050| args = ["values..."];
000051| num_args = 1;
000052| vararg = true;
000053| code = fun env ->
000054| match env.stackframes.(0).(1) with
000055| | RMapValue(t, ArraySubtype) ->
000056| (*[296]*)List.iter (fun value ->
000057| (*[888]*)print_string (string_of_value value)) (list_of_array (RMapValue(t, ArraySubtype)))
000058| | _ -> (*[0]*)raise (RuntimeError.LibraryError "expected vararg for first parameter of print")
000060| {
000061| name = ["println"];
000062| args = ["values..."];
000063| num_args = 1;
000064| vararg = true;
000065| code = fun env ->
000066| match env.stackframes.(0).(1) with
000067| | RMapValue(t, ArraySubtype) ->
000068| (*[380]*)List.iter (fun value ->
000069| (*[602]*)print_string (string_of_value value)) (list_of_array (RMapValue(t, ArraySubtype)));
000070| (*[380]*)print_newline()
000071| | _ -> (*[0]*)raise (RuntimeError.LibraryError "expected vararg for first parameter of println")
000073| {
000074| name =["readln"];
000075| args =[];
000076| num_args = 0;
000077| vararg = false;
000078| code = fun env ->
000079| (*[0]*)raise (CFReturn(RStringValue(read_line())))
000081| {
000082| name =["File";"openForWriting"];
000083| args =["handle"; "filename"];
000084| num_args = 2;
000085| vararg = false;
000086| code = fun env ->
000087| (*[4]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000088| (*[4]*)let filename = string_of_value (env.stackframes.(0).(2)) in
000089| (*[4]*)try
000090| (*[4]*)if Hashtbl.mem descriptors handle then
000091| (*[0]*)raise (EIOPassthrough("handle "^handle^" is already opened in call to openForWriting"))
000093| (*[4]*)let ch = open_out filename in
000094| (*[4]*)Hashtbl.add descriptors handle (OutChannel(ch), filename)
000095| with
000096| | EIOPassthrough(msg) -> (*[0]*)raise (LibraryError msg)
000097| | _ -> (*[0]*)raise (LibraryError ("error opening file "^filename^" in openFileForWriting"))
000099| {
000100| name =["File";"openForReading"];
000101| args =["handle"; "filename"];
000102| num_args = 2;
000103| vararg = false;
000104| code = fun env ->
000105| (*[4]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000106| (*[4]*)let filename = string_of_value (env.stackframes.(0).(2)) in
000107| (*[4]*)try
000108| (*[4]*)if Hashtbl.mem descriptors handle then
000109| (*[0]*)raise (EIOPassthrough("handle "^handle^" is already opened in call to openForReading"))
000111| (*[4]*)let ch = open_in filename in
000112| (*[4]*)Hashtbl.add descriptors handle (InChannel(ch, (try_read ch)), filename)
000113| with
000114| | EIOPassthrough(msg) -> (*[0]*)raise (LibraryError msg)
000115| | _ -> (*[0]*)raise (LibraryError ("error opening file "^filename^" in openFileForReading"))
000117| {
000118| name =["File";"close"];
000119| args =["handle"];
000120| num_args = 1;
000121| vararg = false;
000122| code = fun env ->
000123| (*[8]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000124| (*[8]*)let (c, _ ) = get_descriptor handle "closeFile" in
000125| (*[8]*)try
000126| (match c with
000127| | OutChannel(ch) -> (*[4]*)close_out ch
000128| | InChannel(ch, _) -> (*[4]*)close_in ch);
000129| (*[8]*)Hashtbl.remove descriptors handle
000130| with
000131| | EIOPassthrough(msg) -> (*[0]*)raise (LibraryError msg)
000132| | Sys_error msg -> (*[0]*)raise (LibraryError ("System error on closeFile:" ^ msg ))
000134| {
000135| name =["File";"write"];
000136| args =["handle"; "values..."];
000137| num_args = 2;
000138| vararg = true;
000139| code = fun env ->
000140| (*[2]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000141| (*[2]*)let (c, filename) = get_descriptor handle "write" in
000142| match c with
000143| | OutChannel(ch) ->
000144| ( (*[2]*)try
000145| (*[2]*)let _ = List.map (fun el -> (*[2]*)output_string ch (string_of_value el))
000146| (list_of_array (env.stackframes.(0).(2))) in (*[2]*)()
000147| with
000148| | EIOPassthrough(msg) -> (*[0]*)raise (LibraryError msg)
000149| | _ -> (*[0]*)raise (LibraryError ("error writing file "^filename^" in write")))
000150| | InChannel(ch, _) -> (*[0]*)raise (LibraryError ("invalid handle in call to write. Handle "^handle^" was opened for reading "^filename))
000152| {
000153| name =["File";"writeln"];
000154| args =["handle"; "values..."];
000155| num_args = 2;
000156| vararg = true;
000157| code = fun env ->
000158| (*[22]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000159| (*[22]*)let (c, filename) = get_descriptor handle "writeln" in
000160| match c with
000161| | OutChannel(ch) ->
000162| ((*[22]*)try
000163| (*[22]*)let _ = List.map (fun el -> (*[22]*)output_string ch (string_of_value el))
000164| (list_of_array (env.stackframes.(0).(2))) in
000165| (*[22]*)output_string ch ( "\n")
000166| with
000167| | EIOPassthrough(msg) -> (*[0]*)raise (LibraryError msg)
000168| | _ -> (*[0]*)raise (LibraryError ("error writing file "^filename^" in writeln")))
000169| | InChannel(ch, _) -> (*[0]*)raise (LibraryError ("invalid handle in call to write. Handle "^handle^" was opened for reading "^filename))
000171| {
000172| name =["File";"readln"];
000173| args =["handle"];
000174| num_args = 1;
000175| vararg = false;
000176| code = fun env ->
000177| (*[22]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000178| (*[22]*)let (c, filename) = get_descriptor handle "readln" in
000179| match c with
000180| | OutChannel(ch) -> (*[0]*)raise (EIOPassthrough ("invalid handle in call to readln. Handle "^handle^" was opened for writing "^filename))
000181| | InChannel(ch, (_, true)) -> (*[0]*)raise (EIOPassthrough ("End of file reached for handle "^handle^" in call to readln"))
000183| ( (*[22]*)try
000184| (*[22]*)Hashtbl.replace descriptors handle (InChannel(ch, (try_read ch)), filename)
000185| with
000186| | EIOPassthrough(msg) -> (*[0]*)raise (LibraryError msg)
000187| | _ -> (*[0]*)raise (LibraryError ("error reading file "^filename^" in readln")));
000189| };
000190| {
000191| name =["File";"eof"];
000192| args =["handle"];
000193| num_args = 1;
000194| vararg = false;
000195| code = fun env ->
000196| (*[22]*)let handle = string_of_value (env.stackframes.(0).(1)) in
000197| (*[22]*)let (c, filename) = get_descriptor handle "eof" in
000198| match c with
000199| | OutChannel(ch) -> (*[0]*)raise (EIOPassthrough("invalid handle in call to eof. Handle "^handle^" was opened for writing "^filename))
000201| };
000202| {
000203| name =["File";"exists"];
000204| args =["filename"];
000205| num_args = 1;
000206| vararg = false;
000207| code = fun env ->
000208| (*[8]*)let filename = string_of_value (env.stackframes.(0).(1)) in
000209| (*[8]*)raise (CFReturn(RBooleanValue (Sys.file_exists filename)))
000210| };
000211| {
000212| name =["File";"delete"];
000213| args =["name"];
000214| num_args = 1;
000215| vararg = false;
000216| code = fun env ->
000217| (*[6]*)let name = string_of_value (env.stackframes.(0).(1)) in
000218| (*[6]*)try
000219| (*[6]*)unlink name;
000220| (*[4]*)raise (CFReturn(RBooleanValue(true)))
000221| with
000222| | _ -> (*[6]*)raise (CFReturn(RBooleanValue(false)))
000223|
000224| };
000225| {
000226| name =["File";"rename"];
000227| args =["fromname";"toname"];
000228| num_args = 2;
000229| vararg = false;
000230| code = fun env ->
000231| (*[2]*)let fromname = string_of_value (env.stackframes.(0).(1)) in
000232| (*[2]*)let toname = string_of_value (env.stackframes.(0).(2)) in
000233| (*[2]*)try
000234| (*[2]*)rename fromname toname;
000235| (*[2]*)raise (CFReturn(RBooleanValue(true)))
000236| with
000237| | _ -> (*[2]*)raise (CFReturn(RBooleanValue(false)))
000238| };
000239| {
000240| name =["Directory";"create"];
000241| args =["name"];
000242| num_args = 1;
000243| vararg = false;
000244| code = fun env ->
000245| (*[8]*)let name = string_of_value (env.stackframes.(0).(1)) in
000246| (*[8]*)try
000247| (*[8]*)mkdir name 0o777;
000248| (*[8]*)raise (CFReturn(RBooleanValue(true)))
000249| with
000250| | CFReturn _ as e -> (*[8]*)raise e
000251| | _ -> (*[0]*)raise (CFReturn(RBooleanValue(false)))
000253| {
000254| name =["Directory";"delete"];
000255| args =["name"];
000256| num_args = 1;
000257| vararg = false;
000258| code = fun env ->
000259| (*[8]*)let name = string_of_value (env.stackframes.(0).(1)) in
000260| (*[8]*)try
000261| (*[8]*)rmdir name;
000262| (*[8]*)raise (CFReturn(RBooleanValue(true)))
000263| with
000264| | CFReturn _ as e -> (*[8]*)raise e
000265| | _ -> (*[0]*)raise (CFReturn(RBooleanValue(false)))
000267| {
000268| name =["Directory";"list"];
000269| args =["name"];
000270| num_args = 1;
000271| vararg = false;
000272| code = fun env ->
000273| (*[2]*)let name = string_of_value (env.stackframes.(0).(1)) in
000274| (*[2]*)let arr = (try
000275| (*[2]*)let handle = opendir name in
000276| (*[2]*)let h = Hashtbl.create 10
000277| in (*[2]*)let rec loop cnt =
000278| (*[8]*)try
000279| (*[8]*)Hashtbl.add h (string_of_int cnt) (RStringValue(readdir handle));
000280| (*[6]*)loop (cnt + 1)
000281| with
000282| | End_of_file -> (*[2]*)closedir handle; (*[2]*)cnt
000283| | _ -> (*[0]*)closedir handle; (*[0]*)raise (CFReturn(RVoid))
000287| | _ -> (*[0]*)raise (CFReturn(RVoid)))
000289| };
000290| {
000291| name =["Directory";"exists"];
000292| args =["name"];
000293| num_args = 1;
000294| vararg = false;
000295| code = fun env ->
000296| (*[6]*)let name = string_of_value (env.stackframes.(0).(1)) in
000297| (*[6]*)raise (CFReturn(RBooleanValue((try
000298| (*[6]*)Sys.is_directory name
000299| with
000300| | _ -> (*[2]*)raise (CFReturn(RBooleanValue(false)))))))
000301| };
000302| ], env)