diff --git a/lib/ext/file.c b/lib/ext/file.c index 925fc171..689bd950 100644 --- a/lib/ext/file.c +++ b/lib/ext/file.c @@ -74,12 +74,80 @@ pic_fopen(pic_state *pic, FILE *fp, const char *mode) { } } +PIC_NORETURN static void +file_error(pic_state *pic, const char *msg, const char *fname) +{ + pic_value fn = pic_cstr_value(pic, fname); + + pic_raise(pic, pic_make_error(pic, "file", msg, pic_list(pic, 1, fn))); +} + +pic_value +pic_file_open_input_file(pic_state *pic) +{ + const char *fname; + FILE *fp; + + pic_get_args(pic, "z", &fname); + + if ((fp = fopen(fname, "r")) == NULL) { + file_error(pic, "could not open file", fname); + } + return pic_fopen(pic, fp, "r"); +} + +pic_value +pic_file_open_output_file(pic_state *pic) +{ + const char *fname; + FILE *fp; + + pic_get_args(pic, "z", &fname); + + if ((fp = fopen(fname, "w")) == NULL) { + file_error(pic, "could not open file", fname); + } + return pic_fopen(pic, fp, "w"); +} + +pic_value +pic_file_exists_p(pic_state *pic) +{ + const char *fname; + FILE *fp; + + pic_get_args(pic, "z", &fname); + + fp = fopen(fname, "r"); + if (fp) { + fclose(fp); + } + return pic_bool_value(pic, fp != NULL); +} + +pic_value +pic_file_delete(pic_state *pic) +{ + const char *fname; + + pic_get_args(pic, "z", &fname); + + if (remove(fname) != 0) { + file_error(pic, "file cannot be deleted", fname); + } + return pic_undef_value(pic); +} + void pic_init_file(pic_state *pic) { pic_defvar(pic, "current-input-port", pic_fopen(pic, stdin, "r")); pic_defvar(pic, "current-output-port", pic_fopen(pic, stdout, "w")); pic_defvar(pic, "current-error-port", pic_fopen(pic, stdout, "w")); + pic_defun(pic, "open-binary-input-file", pic_file_open_input_file); + pic_defun(pic, "open-binary-output-file", pic_file_open_output_file); + pic_defun(pic, "file-exists?", pic_file_exists_p); + pic_defun(pic, "delete-file", pic_file_delete); } #endif diff --git a/lib/gc.c b/lib/gc.c index f0b0b775..0afb9040 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -417,7 +417,7 @@ gc_finalize_object(pic_state *pic, struct object *obj) case PIC_TYPE_IREP: { struct irep *irep = &obj->u.irep; if ((irep->flags & IREP_CODE_STATIC) == 0) { - pic_free(pic, irep->code); + pic_free(pic, (code_t *) irep->code); } pic_free(pic, irep->obj); pic_free(pic, irep->irep);