add pic_open_file

contrib/05.r7rs/src/file.c

@@ -14,24 +14,6 @@ file_error(pic_state *pic, const char *msg)
   pic_raise(pic, pic_obj_value(e));
 }
 
-static pic_value
-generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
-{
-  struct pic_port *port;
-  xFILE *file;
-
-  file = xfopen(pic, fname, mode);
-  if (! file) {
-    file_error(pic, "could not open file");
-  }
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
-  port->file = file;
-  port->flags = flags | PIC_PORT_OPEN;
-
-  return pic_obj_value(port);
-}
-
 pic_value
 pic_file_open_input_file(pic_state *pic)
 {
@@ -40,7 +22,7 @@ pic_file_open_input_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "r", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value
@@ -51,7 +33,7 @@ pic_file_open_binary_input_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "rb", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value
@@ -62,7 +44,7 @@ pic_file_open_output_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "w", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value
@@ -73,7 +55,7 @@ pic_file_open_binary_output_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "wb", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value

contrib/05.r7rs/src/load.c

@@ -8,16 +8,8 @@ void
 pic_load(pic_state *pic, const char *filename)
 {
   struct pic_port *port;
-  xFILE *file;
 
-  file = xfopen(pic, filename, "r");
+  port = pic_open_file(pic, filename, PIC_PORT_IN | PIC_PORT_TEXT);
-  if (file == NULL) {
-    pic_errorf(pic, "could not open file: %s", filename);
-  }
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
-  port->file = file;
-  port->flags = PIC_PORT_IN | PIC_PORT_TEXT | PIC_PORT_OPEN;
 
   pic_load_port(pic, port);
 

extlib/benz/file.c

@@ -1,79 +1,5 @@
 #include "picrin.h"
 
-static int
-file_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) {
-  FILE *file = cookie;
-  int r;
-
-  size = 1;                     /* override size */
-
-  r = (int)fread(ptr, 1, (size_t)size, file);
-  if (r < size && ferror(file)) {
-    return -1;
-  }
-  if (r == 0 && feof(file)) {
-    clearerr(file);
-  }
-  return r;
-}
-
-static int
-file_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) {
-  FILE *file = cookie;
-  int r;
-
-  r = (int)fwrite(ptr, 1, (size_t)size, file);
-  if (r < size) {
-    return -1;
-  }
-  fflush(cookie);
-  return r;
-}
-
-static long
-file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) {
-  switch (whence) {
-  case XSEEK_CUR:
-    whence = SEEK_CUR;
-    break;
-  case XSEEK_SET:
-    whence = SEEK_SET;
-    break;
-  case XSEEK_END:
-    whence = SEEK_END;
-    break;
-  }
-  return fseek(cookie, pos, whence);
-}
-
-static int
-file_close(pic_state PIC_UNUSED(*pic), void *cookie) {
-  return fclose(cookie);
-}
-
-xFILE *xfopen(pic_state *pic, const char *name, const char *mode) {
-  FILE *fp;
-
-  if ((fp = fopen(name, mode)) == NULL) {
-    return NULL;
-  }
-
-  switch (*mode) {
-  case 'r':
-    return xfunopen(pic, fp, file_read, NULL, file_seek, file_close);
-  default:
-    return xfunopen(pic, fp, NULL, file_write, file_seek, file_close);
-  }
-}
-
-#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close }
-
-const xFILE x_iob[XOPEN_MAX] = {
-  { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ },
-  { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_LNBUF },
-  { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF }
-};
-
 xFILE *xfunopen(pic_state *pic, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)) {
   xFILE *fp;
 

extlib/benz/include/picrin/file.h

@@ -64,7 +64,6 @@ enum _flags {
 
 /* resource aquisition */
 xFILE *xfunopen(pic_state *, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *));
-xFILE *xfopen(pic_state *, const char *, const char *);
 int xfclose(pic_state *, xFILE *);
 
 /* buffer management */

extlib/benz/include/picrin/port.h

@@ -32,6 +32,7 @@ struct pic_port *pic_open_input_string(pic_state *, const char *);
 struct pic_port *pic_open_output_string(pic_state *);
 struct pic_string *pic_get_output_string(pic_state *, struct pic_port *);
 
+struct pic_port *pic_open_file(pic_state *, const char *, int);
 void pic_close_port(pic_state *pic, struct pic_port *);
 
 #if defined(__cplusplus)

extlib/benz/port.c

@@ -26,6 +26,93 @@ pic_assert_port(pic_state *pic)
 
 /* current-(input|output|error)-port */
 
+static int
+file_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) {
+  FILE *file = cookie;
+  int r;
+
+  size = 1;                     /* override size */
+
+  r = (int)fread(ptr, 1, (size_t)size, file);
+  if (r < size && ferror(file)) {
+    return -1;
+  }
+  if (r == 0 && feof(file)) {
+    clearerr(file);
+  }
+  return r;
+}
+
+static int
+file_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) {
+  FILE *file = cookie;
+  int r;
+
+  r = (int)fwrite(ptr, 1, (size_t)size, file);
+  if (r < size) {
+    return -1;
+  }
+  fflush(cookie);
+  return r;
+}
+
+static long
+file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) {
+  switch (whence) {
+  case XSEEK_CUR:
+    whence = SEEK_CUR;
+    break;
+  case XSEEK_SET:
+    whence = SEEK_SET;
+    break;
+  case XSEEK_END:
+    whence = SEEK_END;
+    break;
+  }
+  return fseek(cookie, pos, whence);
+}
+
+static int
+file_close(pic_state PIC_UNUSED(*pic), void *cookie) {
+  return fclose(cookie);
+}
+
+static xFILE *
+file_open(pic_state *pic, const char *name, const char *mode) {
+  FILE *fp;
+
+  if ((fp = fopen(name, mode)) == NULL) {
+    return NULL;
+  }
+
+  switch (*mode) {
+  case 'r':
+    return xfunopen(pic, fp, file_read, NULL, file_seek, file_close);
+  default:
+    return xfunopen(pic, fp, NULL, file_write, file_seek, file_close);
+  }
+}
+
+struct pic_port *
+pic_open_file(pic_state *pic, const char *name, int flags) {
+  struct pic_port *port;
+  xFILE *file;
+  char mode = 'r';
+
+  if ((flags & PIC_PORT_IN) == 0) {
+    mode = 'w';
+  }
+  if ((file = file_open(pic, name, &mode)) == NULL) {
+    pic_errorf(pic, "could not open file '%s'", name);
+  }
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+  port->file = file;
+  port->flags = flags | PIC_PORT_OPEN;
+
+  return port;
+}
+
 static void
 pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir)
 {
@@ -762,6 +849,22 @@ pic_port_flush(pic_state *pic)
 void
 pic_init_port(pic_state *pic)
 {
+#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close }
+
+  static const xFILE skel[3] = {
+    { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ },
+    { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_LNBUF },
+    { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF }
+  };
+
+  pic->files[0] = skel[0];
+  pic->files[1] = skel[1];
+  pic->files[2] = skel[2];
+
+  pic->files[0].vtable.cookie = stdin;
+  pic->files[1].vtable.cookie = stdout;
+  pic->files[2].vtable.cookie = stderr;
+
   pic_define_standard_port(pic, "current-input-port", xstdin, PIC_PORT_IN);
   pic_define_standard_port(pic, "current-output-port", xstdout, PIC_PORT_OUT);
   pic_define_standard_port(pic, "current-error-port", xstderr, PIC_PORT_OUT);

extlib/benz/state.c

@@ -248,10 +248,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
   pic->err = pic_invalid_value();
 
   /* file pool */
-  memcpy(pic->files, x_iob, sizeof pic->files);
+  memset(pic->files, 0, sizeof pic->files);
-  pic->files[0].vtable.cookie = stdin;
-  pic->files[1].vtable.cookie = stdout;
-  pic->files[2].vtable.cookie = stderr;
 
   /* parameter table */
   pic->ptable = pic_nil_value();