diff --git a/main.ml b/main.ml index 898be79..c4836d2 100644 --- a/main.ml +++ b/main.ml @@ -2864,6 +2864,8 @@ let rec generate (letfuncs, strings, typedefs, exps) = gen_c_func "aqaml_printf_ksprintf5" [CTyPtr; CTyPtr; CTyPtr; CTyPtr; CTyPtr; CTyPtr] CTyPtr ; + gen_c_func "aqaml_get_stdin" [CTyUnit] CTyPtr ; + gen_c_func "aqaml_close_in" [CTyPtr] CTyUnit ; appstr buf "aqaml_input_char:" ; let exit_label = make_label () in appstr buf "mov rdi, rax" ; @@ -2874,6 +2876,18 @@ let rec generate (letfuncs, strings, typedefs, exps) = appfmt buf "%s:" exit_label ; appstr buf "ret" ; appstr buf "" ; + appstr buf "aqaml_open_in:" ; + let exit_label = make_label () in + appstr buf "mov rdi, rax" ; + appstr buf "call aqaml_open_in_detail@PLT" ; + appstr buf "cmp rax, 0" ; + appfmt buf "jne %s" exit_label ; + (* TODO: raise 'No such file or directory *) + appstr buf "mov rax, 0" ; + appstr buf @@ gen_raise_exp_of "Sys_error" true ; + appfmt buf "%s:" exit_label ; + appstr buf "ret" ; + appstr buf "" ; appstr buf "aqaml_structural_inequal:" ; appstr buf "mov rdi, rax" ; appstr buf "mov rsi, rbx" ; diff --git a/stdlib.ml b/stdlib.ml index 2068196..64495c2 100644 --- a/stdlib.ml +++ b/stdlib.ml @@ -20,12 +20,20 @@ exception Not_found exception Failure of string +exception Sys_error of string + type in_channel = {descriptor: int} -let stdin = {descriptor= 0} +external _aqaml_get_stdin : unit -> in_channel = "aqaml_get_stdin" + +let stdin = _aqaml_get_stdin () external input_char : in_channel -> char = "aqaml_input_char" +external open_in : string -> in_channel = "aqaml_open_in" + +external close_in : string -> in_channel = "aqaml_close_in" + type 'a option = Some of 'a | None let ignore _ = () diff --git a/test.ml b/test.ml index 0e98cf5..29a5c72 100644 --- a/test.ml +++ b/test.ml @@ -1633,3 +1633,9 @@ let sub x y = x - y ;; test (10 |> add 2 |> sub 8) (-4) + +;; +let ch = open_in "test.ml" in +test (input_char ch) 'l' ; +test (input_char ch) 'e' ; +close_in ch diff --git a/utility.c b/utility.c index b3b8254..168255d 100644 --- a/utility.c +++ b/utility.c @@ -207,13 +207,40 @@ void aqaml_prerr_string_detail(uint64_t ptr) for (uint64_t i = 0; i < length; i++) fputc(val.string->str[i], stderr); } +uint64_t aqaml_open_in_detail(uint64_t path_src) +{ + AQamlValue path = get_value(path_src); + assert(path.kind == AQAML_STRING); + FILE *fp = fopen((char *)(path.string->str), "r"); + if (fp == NULL) return 0; + uint64_t ret_src = aqaml_alloc_block(1, 0, 247); + AQamlValue ret = get_value(ret_src); + ret.array->data[0] = (uint64_t)fp; + return ret_src; +} + +void aqaml_close_in_detail(uint64_t chan_src) +{ + AQamlValue chan = get_value(chan_src); + assert(chan.kind == AQAML_ARRAY); + FILE *fp = (FILE *)(chan.array->data[0]); + fclose(fp); +} + +uint64_t aqaml_get_stdin_detail() +{ + uint64_t ret_src = aqaml_alloc_block(1, 0, 247); + AQamlValue ret = get_value(ret_src); + ret.array->data[0] = (uint64_t)stdin; + return ret_src; +} + uint64_t aqaml_input_char_detail(uint64_t ptr) { AQamlValue chan = get_value(ptr); assert(chan.kind == AQAML_ARRAY); - uint64_t fd = chan.array->data[0] >> 1; - assert(fd == 0); // TODO: other in_channel - int ch = fgetc(stdin); + FILE *fp = (FILE *)(chan.array->data[0]); + int ch = fgetc(fp); if (ch == EOF) return -1; return ((uint64_t)ch << 1) | 1; }