conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rename I/O functions

This commit is contained in:
Yuichi Nishiwaki 2016-06-20 04:49:01 +09:00
parent a1116d39eb
commit 9515060b00
22 changed files with 975 additions and 1017 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
contrib/20.r7rs/src/file.c
View File

@ -21,7 +21,7 @@ open_file(pic_state *pic, const char *fname, const char *mode)
if ((fp = fopen(fname, mode)) == NULL) {
file_error(pic, "could not open file...");
}
return pic_open_port(pic, xfopen_file(pic, fp, mode));
return pic_fopen(pic, fp, mode);
}
pic_value

4
contrib/20.r7rs/src/load.c
View File

@ -21,11 +21,11 @@ pic_load_load(pic_state *pic)
pic_error(pic, "load: could not open file", 1, pic_cstr_value(pic, fn));
}
port = pic_open_port(pic, xfopen_file(pic, fp, "r"));
port = pic_fopen(pic, fp, "r");
pic_load(pic, port);
pic_close_port(pic, port);
pic_fclose(pic, port);
return pic_undef_value(pic);
}

8
contrib/40.srfi/src/106.c
View File

@ -297,15 +297,11 @@ xf_socket_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie))
static pic_value
make_socket_port(pic_state *pic, struct pic_socket_t *sock, const char *mode)
{
xFILE *fp;
if (*mode == 'r') {
fp = xfunopen(pic, sock, xf_socket_read, 0, xf_socket_seek, xf_socket_close);
return pic_funopen(pic, sock, xf_socket_read, 0, xf_socket_seek, xf_socket_close);
} else {
fp = xfunopen(pic, sock, 0, xf_socket_write, xf_socket_seek, xf_socket_close);
return pic_funopen(pic, sock, 0, xf_socket_write, xf_socket_seek, xf_socket_close);
}
return pic_open_port(pic, fp);
}
static pic_value

2
etc/mkloader.pl
View File

@ -55,7 +55,7 @@ EOL
}
pic_catch(e) {
/* error! */
xfputs(pic, "fatal error: failure in loading $dirname/$basename\\n", xstderr);
pic_fputs(pic, "fatal error: failure in loading $dirname/$basename\\n", pic_stderr(pic));
pic_raise(pic, e);
}
EOL

4
extlib/benz/debug.c
View File

@ -38,10 +38,8 @@ pic_get_backtrace(pic_state *pic)
#if PIC_USE_WRITE
void
pic_print_error(pic_state *pic, xFILE *file, pic_value err)
pic_print_error(pic_state *pic, pic_value port, pic_value err)
{
pic_value port = pic_open_port(pic, file);
if (! pic_error_p(pic, err)) {
pic_fprintf(pic, port, "raise: ~s", err);
} else {

3
extlib/benz/error.c
View File

@ -26,7 +26,6 @@ pic_panic(pic_state *pic, const char *msg)
void
pic_warnf(pic_state *pic, const char *fmt, ...)
{
xFILE *file = pic_fileno(pic, pic_stderr(pic));
va_list ap;
pic_value err;
@ -34,7 +33,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
err = pic_vstrf_value(pic, fmt, ap);
va_end(ap);
xfprintf(pic, file, "warn: %s\n", pic_str(pic, err));
pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err));
}
static pic_value

558
extlib/benz/file.c
View File

@ -1,558 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/private/state.h"
#ifndef EOF
# define EOF (-1)
#endif
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;
for (fp = pic->files; fp < pic->files + XOPEN_MAX; fp++)
if ((fp->flag & (X_READ | X_WRITE)) == 0)
break; /* found free slot */
if (fp >= pic->files + XOPEN_MAX) /* no free slots */
return NULL;
fp->cnt = 0;
fp->base = NULL;
fp->flag = read? X_READ : X_WRITE;
fp->vtable.cookie = cookie;
fp->vtable.read = read;
fp->vtable.write = write;
fp->vtable.seek = seek;
fp->vtable.close = close;
return fp;
}
int xfclose(pic_state *pic, xFILE *fp) {
xfflush(pic, fp);
fp->flag = 0;
if (fp->base != fp->buf)
pic_free(pic, fp->base);
return fp->vtable.close(pic, fp->vtable.cookie);
}
void xclearerr(pic_state *PIC_UNUSED(pic), xFILE *fp) {
fp->flag &= ~(X_EOF | X_ERR);
}
int xfeof(pic_state *PIC_UNUSED(pic), xFILE *fp) {
return (fp->flag & X_EOF) != 0;
}
int xferror(pic_state *PIC_UNUSED(pic), xFILE *fp) {
return (fp->flag & X_ERR) != 0;
}
int x_fillbuf(pic_state *pic, xFILE *fp) {
int bufsize;
if ((fp->flag & (X_READ|X_EOF|X_ERR)) != X_READ)
return EOF;
if (fp->base == NULL) {
if ((fp->flag & X_UNBUF) == 0) {
/* no buffer yet */
if ((fp->base = pic_malloc(pic, XBUFSIZ)) == NULL) {
/* can't get buffer, try unbuffered */
fp->flag |= X_UNBUF;
}
}
if (fp->flag & X_UNBUF) {
fp->base = fp->buf;
}
}
bufsize = (fp->flag & X_UNBUF) ? sizeof(fp->buf) : XBUFSIZ;
fp->ptr = fp->base;
fp->cnt = fp->vtable.read(pic, fp->vtable.cookie, fp->ptr, bufsize);
if (--fp->cnt < 0) {
if (fp->cnt == -1)
fp->flag |= X_EOF;
else
fp->flag |= X_ERR;
fp->cnt = 0;
return EOF;
}
return (unsigned char) *fp->ptr++;
}
int x_flushbuf(pic_state *pic, int x, xFILE *fp) {
int num_written=0, bufsize=0;
char c = x;
if ((fp->flag & (X_WRITE|X_EOF|X_ERR)) != X_WRITE)
return EOF;
if (fp->base == NULL && ((fp->flag & X_UNBUF) == 0)) {
/* no buffer yet */
if ((fp->base = pic_malloc(pic, XBUFSIZ)) == NULL) {
/* couldn't allocate a buffer, so try unbuffered */
fp->flag |= X_UNBUF;
} else {
fp->ptr = fp->base;
fp->cnt = XBUFSIZ - 1;
}
}
if (fp->flag & X_UNBUF) {
/* unbuffered write */
fp->ptr = fp->base = NULL;
fp->cnt = 0;
if (x == EOF)
return EOF;
num_written = fp->vtable.write(pic, fp->vtable.cookie, (const char *) &c, 1);
bufsize = 1;
} else {
/* buffered write */
assert(fp->ptr);
if (x != EOF) {
*fp->ptr++ = (unsigned char) c;
}
bufsize = (int)(fp->ptr - fp->base);
while(bufsize - num_written > 0) {
int t;
t = fp->vtable.write(pic, fp->vtable.cookie, fp->base + num_written, bufsize - num_written);
if (t < 0)
break;
num_written += t;
}
fp->ptr = fp->base;
fp->cnt = XBUFSIZ - 1;
}
if (num_written == bufsize) {
return x;
} else {
fp->flag |= X_ERR;
return EOF;
}
}
int xfflush(pic_state *pic, xFILE *f) {
int retval;
int i;
retval = 0;
if (f == NULL) {
/* flush all output streams */
for (i = 0; i < XOPEN_MAX; i++) {
if ((pic->files[i].flag & X_WRITE) && (xfflush(pic, &pic->files[i]) == -1))
retval = -1;
}
} else {
if ((f->flag & X_WRITE) == 0)
return -1;
x_flushbuf(pic, EOF, f);
if (f->flag & X_ERR)
retval = -1;
}
return retval;
}
#define xgetc(pic, p) \
((--(p)->cnt >= 0) \
? (unsigned char) *(p)->ptr++ \
: x_fillbuf((pic), p))
#define xputc(pic, x, p) \
((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \
? *(p)->ptr++ = (x) \
: x_flushbuf((pic), (x), (p)))
int xfputc(pic_state *pic, int x, xFILE *fp) {
return xputc(pic, x, fp);
}
int xfgetc(pic_state *pic, xFILE *fp) {
return xgetc(pic, fp);
}
int xfputs(pic_state *pic, const char *s, xFILE *stream) {
const char *ptr = s;
while(*ptr != '\0') {
if (xputc(pic, *ptr, stream) == EOF)
return EOF;
++ptr;
}
return (int)(ptr - s);
}
char *xfgets(pic_state *pic, char *s, int size, xFILE *stream) {
int c = 0;
char *buf;
xfflush(pic, NULL);
if (size == 0) {
return NULL;
}
buf = s;
while (--size > 0 && (c = xgetc(pic, stream)) != EOF) {
if ((*buf++ = c) == '\n')
break;
}
*buf = '\0';
return (c == EOF && buf == s) ? NULL : s;
}
int xungetc(pic_state *PIC_UNUSED(pic), int c, xFILE *fp) {
unsigned char uc = c;
if (c == EOF || fp->base == fp->ptr) {
return EOF;
}
fp->cnt++;
return *--fp->ptr = uc;
}
size_t xfread(pic_state *pic, void *ptr, size_t size, size_t count, xFILE *fp) {
char *bptr = ptr;
long nbytes;
int c;
nbytes = size * count;
while (nbytes > fp->cnt) {
memcpy(bptr, fp->ptr, fp->cnt);
fp->ptr += fp->cnt;
bptr += fp->cnt;
nbytes -= fp->cnt;
if ((c = x_fillbuf(pic, fp)) == EOF) {
return (size * count - nbytes) / size;
} else {
xungetc(pic, c, fp);
}
}
memcpy(bptr, fp->ptr, nbytes);
fp->ptr += nbytes;
fp->cnt -= nbytes;
return count;
}
size_t xfwrite(pic_state *pic, const void *ptr, size_t size, size_t count, xFILE *fp) {
const char *bptr = ptr;
long nbytes;
nbytes = size * count;
while (nbytes > fp->cnt) {
memcpy(fp->ptr, bptr, fp->cnt);
fp->ptr += fp->cnt;
bptr += fp->cnt;
nbytes -= fp->cnt;
if (x_flushbuf(pic, EOF, fp) == EOF) {
return (size * count - nbytes) / size;
}
}
memcpy(fp->ptr, bptr, nbytes);
fp->ptr += nbytes;
fp->cnt -= nbytes;
return count;
}
long xfseek(pic_state *pic, xFILE *fp, long offset, int whence) {
long s;
xfflush(pic, fp);
fp->ptr = fp->base;
fp->cnt = 0;
if ((s = fp->vtable.seek(pic, fp->vtable.cookie, offset, whence)) != 0)
return s;
fp->flag &= ~X_EOF;
return 0;
}
int xfprintf(pic_state *pic, xFILE *stream, const char *fmt, ...) {
va_list ap;
int n;
va_start(ap, fmt);
n = xvfprintf(pic, stream, fmt, ap);
va_end(ap);
return n;
}
static int print_int(pic_state *pic, xFILE *stream, long x, int base) {
static const char digits[] = "0123456789abcdef";
char buf[20];
int i, c, neg;
neg = 0;
if (x < 0) {
neg = 1;
x = -x;
}
i = 0;
do {
buf[i++] = digits[x % base];
} while ((x /= base) != 0);
if (neg) {
buf[i++] = '-';
}
c = i;
while (i-- > 0) {
xputc(pic, buf[i], stream);
}
return c;
}
int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) {
const char *p;
char *sval;
int ival;
void *vp;
int cnt = 0;
for (p = fmt; *p; p++) {
if (*p != '%') {
xputc(pic, *p, stream);
cnt++;
continue;
}
switch (*++p) {
case 'd':
case 'i':
ival = va_arg(ap, int);
cnt += print_int(pic, stream, ival, 10);
break;
case 'f': {
char buf[64];
PIC_DOUBLE_TO_CSTRING(va_arg(ap, double), buf);
cnt += xfputs(pic, buf, stream);
break;
}
case 'c':
ival = va_arg(ap, int);
cnt += xfputc(pic, ival, stream);
break;
case 's':
sval = va_arg(ap, char*);
cnt += xfputs(pic, sval, stream);
break;
case 'p':
vp = va_arg(ap, void*);
cnt += xfputs(pic, "0x", stream);
cnt += print_int(pic, stream, (long)vp, 16);
break;
case '%':
xputc(pic, *(p-1), stream);
cnt++;
break;
default:
xputc(pic, '%', stream);
xputc(pic, *(p-1), stream);
cnt += 2;
break;
}
}
return cnt;
}
xFILE *xfile_xstdin(pic_state *pic) { return &pic->files[0]; }
xFILE *xfile_xstdout(pic_state *pic) { return &pic->files[1]; }
xFILE *xfile_xstderr(pic_state *pic) { return &pic->files[2]; }
#if PIC_USE_STDIO
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;
}
if (fseek(cookie, pos, whence) == 0) {
return ftell(cookie);
}
return -1;
}
static int
file_close(pic_state *PIC_UNUSED(pic), void *cookie) {
return fclose(cookie);
}
xFILE *xfopen_file(pic_state *pic, FILE *fp, const char *mode) {
xFILE *f;
if (*mode == 'r') {
f = xfunopen(pic, fp, file_read, 0, file_seek, file_close);
} else {
f = xfunopen(pic, fp, 0, file_write, file_seek, file_close);
}
return f;
}
#endif
typedef struct { char *buf; long pos, end, capa; } xbuf_t;
static int
string_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size)
{
xbuf_t *m = cookie;
if (size > (int)(m->end - m->pos))
size = (int)(m->end - m->pos);
memcpy(ptr, m->buf + m->pos, size);
m->pos += size;
return size;
}
static int
string_write(pic_state *pic, void *cookie, const char *ptr, int size)
{
xbuf_t *m = cookie;
if (m->pos + size >= m->capa) {
m->capa = (m->pos + size) * 2;
m->buf = pic_realloc(pic, m->buf, m->capa);
}
memcpy(m->buf + m->pos, ptr, size);
m->pos += size;
if (m->end < m->pos)
m->end = m->pos;
return size;
}
static long
string_seek(pic_state *PIC_UNUSED(pic), void *cookie, long pos, int whence)
{
xbuf_t *m = cookie;
switch (whence) {
case XSEEK_SET:
m->pos = pos;
break;
case XSEEK_CUR:
m->pos += pos;
break;
case XSEEK_END:
m->pos = m->end + pos;
break;
}
return m->pos;
}
static int
string_close(pic_state *pic, void *cookie)
{
xbuf_t *m = cookie;
pic_free(pic, m->buf);
pic_free(pic, m);
return 0;
}
xFILE *xfopen_buf(pic_state *pic, const char *data, int size, const char *mode) {
xbuf_t *m;
xFILE *file;
m = pic_malloc(pic, sizeof(xbuf_t));
m->buf = pic_malloc(pic, size);
m->pos = 0;
m->end = size;
m->capa = size;
if (*mode == 'r') {
memcpy(m->buf, data, size);
file = xfunopen(pic, m, string_read, NULL, string_seek, string_close);
} else {
file = xfunopen(pic, m, NULL, string_write, string_seek, string_close);
}
if (file == NULL) {
string_close(pic, m);
}
return file;
}
int xfget_buf(pic_state *pic, xFILE *file, const char **buf, int *len) {
xbuf_t *s;
xfflush(pic, file);
if (file->vtable.write != string_write) {
return -1;
}
s = file->vtable.cookie;
*len = s->end;
*buf = s->buf;
return 0;
}
static int
null_read(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), char *PIC_UNUSED(ptr), int PIC_UNUSED(size)) {
return 0;
}
static int
null_write(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), const char *PIC_UNUSED(ptr), int size) {
return size;
}
static long
null_seek(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) {
return 0;
}
static int
null_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie)) {
return 0;
}
xFILE *xfopen_null(pic_state *PIC_UNUSED(pic), const char *mode) {
switch (*mode) {
case 'r':
return xfunopen(pic, 0, null_read, 0, null_seek, null_close);
default:
return xfunopen(pic, 0, 0, null_write, null_seek, null_close);
}
}

4
extlib/benz/include/picconf.h
View File

@ -16,3 +16,7 @@
/* #define PIC_SETJMP(pic, buf) setjmp(buf) */
/* #define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) */
/* #define PIC_ABORT(pic) abort() */
/** I/O configuration */
/* #define PIC_OPEN_MAX 1024 */
/* #define PIC_BUFSIZ 1024 */

45
extlib/benz/include/picrin.h
View File

@ -111,12 +111,6 @@ pic_value pic_vcall(pic_state *, pic_value proc, int, va_list);
pic_value pic_apply(pic_state *, pic_value proc, int n, pic_value *argv);
pic_value pic_applyk(pic_state *, pic_value proc, int n, pic_value *argv);
typedef struct xFILE xFILE;
pic_value pic_open_port(pic_state *, xFILE *file);
xFILE *pic_fileno(pic_state *, pic_value port);
void pic_close_port(pic_state *, pic_value port);
int pic_int(pic_state *, pic_value i);
double pic_float(pic_state *, pic_value f);
char pic_char(pic_state *, pic_value c);
@ -273,29 +267,30 @@ int pic_str_hash(pic_state *, pic_value str);
/* External I/O */
#define XSEEK_CUR 0
#define XSEEK_END 1
#define XSEEK_SET 2
#define PIC_SEEK_CUR 0
#define PIC_SEEK_END 1
#define PIC_SEEK_SET 2
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 *));
size_t xfread(pic_state *, void *ptr, size_t size, size_t count, xFILE *fp);
size_t xfwrite(pic_state *, const void *ptr, size_t size, size_t count, xFILE *fp);
long xfseek(pic_state *, xFILE *fp, long offset, int whence);
int xfclose(pic_state *, xFILE *fp);
pic_value pic_funopen(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 *));
size_t pic_fread(pic_state *, void *ptr, size_t size, size_t count, pic_value port);
size_t pic_fwrite(pic_state *, const void *ptr, size_t size, size_t count, pic_value port);
long pic_fseek(pic_state *, pic_value port, long offset, int whence);
int pic_fclose(pic_state *, pic_value port);
void xclearerr(pic_state *, xFILE *fp);
int xfeof(pic_state *, xFILE *fp);
int xferror(pic_state *, xFILE *fp);
void pic_clearerr(pic_state *, pic_value port);
int pic_feof(pic_state *, pic_value port);
int pic_ferror(pic_state *, pic_value port);
int xfputc(pic_state *, int c, xFILE *fp);
int xfgetc(pic_state *, xFILE *fp);
int xfputs(pic_state *, const char *s, xFILE *fp);
char *xfgets(pic_state *, char *s, int size, xFILE *fp);
int xungetc(pic_state *, int c, xFILE *fp);
int xfflush(pic_state *, xFILE *fp);
int pic_fputc(pic_state *, int c, pic_value port);
int pic_fgetc(pic_state *, pic_value port);
int pic_fputs(pic_state *, const char *s, pic_value port);
char *pic_fgets(pic_state *, char *s, int size, pic_value port);
int pic_ungetc(pic_state *, int c, pic_value port);
int pic_fflush(pic_state *, pic_value port);
int xfprintf(pic_state *, xFILE *fp, const char *fmt, ...);
int xvfprintf(pic_state *, xFILE *fp, const char *fmt, va_list);
int pic_printf(pic_state *, const char *fmt, ...);
int pic_fprintf(pic_state *, pic_value port, const char *fmt, ...);
int pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap);
#if defined(__cplusplus)

31
extlib/benz/include/picrin/extra.h
View File

@ -23,33 +23,16 @@ pic_value pic_eval(pic_state *, pic_value program, const char *lib);
void pic_load(pic_state *, pic_value port);
void pic_load_cstr(pic_state *, const char *);
#if PIC_USE_WRITE
void pic_printf(pic_state *, const char *fmt, ...);
void pic_fprintf(pic_state *, pic_value port, const char *fmt, ...);
void pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap);
#endif
/* extra xfile methods */
xFILE *xfile_xstdin(pic_state *);
xFILE *xfile_xstdout(pic_state *);
xFILE *xfile_xstderr(pic_state *);
#define xstdin (xfile_xstdin(pic))
#define xstdout (xfile_xstdout(pic))
#define xstderr (xfile_xstderr(pic))
#if PIC_USE_STDIO
xFILE *xfopen_file(pic_state *, FILE *, const char *mode);
#endif
xFILE *xfopen_buf(pic_state *, const char *buf, int len, const char *mode);
int xfget_buf(pic_state *, xFILE *file, const char **buf, int *len);
xFILE *xfopen_null(pic_state *, const char *mode);
/* port manipulation */
#define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0)
#define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0)
#define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0)
#if PIC_USE_STDIO
pic_value pic_fopen(pic_state *, FILE *, const char *mode);
#endif
pic_value pic_fmemopen(pic_state *, const char *buf, int len, const char *mode);
int pic_fgetbuf(pic_state *, pic_value port, const char **buf, int *len);
/* utility macros */
#define pic_for_each(var, list, it) \
@ -98,7 +81,7 @@ xFILE *xfopen_null(pic_state *, const char *mode);
void pic_warnf(pic_state *, const char *, ...);
pic_value pic_get_backtrace(pic_state *);
#if PIC_USE_WRITE
void pic_print_error(pic_state *, xFILE *, pic_value err);
void pic_print_error(pic_state *, pic_value port, pic_value err);
#endif
#if defined(__cplusplus)

17
extlib/benz/include/picrin/private/file.h
View File

@ -5,10 +5,7 @@
extern "C" {
#endif
#define XBUFSIZ 1024
#define XOPEN_MAX 1024
struct xFILE {
struct file {
/* buffer */
char buf[1]; /* fallback buffer */
long cnt; /* characters left */
@ -26,12 +23,12 @@ struct xFILE {
};
enum {
X_READ = 01,
X_WRITE = 02,
X_UNBUF = 04,
X_EOF = 010,
X_ERR = 020,
X_LNBUF = 040
FILE_READ = 01,
FILE_WRITE = 02,
FILE_UNBUF = 04,
FILE_EOF = 010,
FILE_ERR = 020,
FILE_LNBUF = 040
};

2
extlib/benz/include/picrin/private/object.h
View File

@ -127,7 +127,7 @@ struct error {
struct port {
OBJECT_HEADER
xFILE *file;
struct file *file;
};
struct checkpoint {

3
extlib/benz/include/picrin/private/state.h
View File

@ -11,7 +11,6 @@ extern "C" {
#include "picrin/private/khash.h"
#include "picrin/private/file.h"
#include "picrin/private/vm.h"
#include "picrin/private/gc.h"
@ -61,7 +60,7 @@ struct pic_state {
khash_t(ltable) ltable;
struct list_head ireps;
xFILE files[XOPEN_MAX];
struct file files[PIC_OPEN_MAX];
bool gc_enable;
struct heap *heap;

8
extlib/benz/include/picrin/setup.h
View File

@ -36,6 +36,14 @@ void abort(void);
# define PIC_ABORT(pic) abort()
#endif
#ifndef PIC_OPEN_MAX
# define PIC_OPEN_MAX 1024
#endif
#ifndef PIC_BUFSIZ
# define PIC_BUFSIZ 1024
#endif
#ifndef PIC_ARENA_SIZE
# define PIC_ARENA_SIZE (8 * 1024)
#endif

6
extlib/benz/load.c
View File

@ -21,15 +21,15 @@ pic_load(pic_state *pic, pic_value port)
void
pic_load_cstr(pic_state *pic, const char *str)
{
pic_value e, port = pic_open_port(pic, xfopen_buf(pic, str, strlen(str), "r"));
pic_value e, port = pic_fmemopen(pic, str, strlen(str), "r");
pic_try {
pic_load(pic, port);
}
pic_catch(e) {
pic_close_port(pic, port);
pic_fclose(pic, port);
pic_raise(pic, e);
}
pic_close_port(pic, port);
pic_fclose(pic, port);
}

8
extlib/benz/number.c
View File

@ -235,14 +235,14 @@ pic_number_number_to_string(pic_state *pic)
str = pic_str_value(pic, buf, ilen);
}
else {
xFILE *file = xfopen_buf(pic, NULL, 0, "w");
pic_value port = pic_fmemopen(pic, NULL, 0, "w");
const char *buf;
int len;
xfprintf(pic, file, "%f", f);
xfget_buf(pic, file, &buf, &len);
pic_fprintf(pic, port, "%f", f);
pic_fgetbuf(pic, port, &buf, &len);
str = pic_str_value(pic, buf, len);
xfclose(pic, file);
pic_fclose(pic, port);
}
return str;

602
extlib/benz/port.c
View File

@ -4,40 +4,544 @@
#include "picrin.h"
#include "picrin/extra.h"
#include "picrin/private/state.h"
#include "picrin/private/object.h"
#include "picrin/private/file.h"
#undef EOF
#define EOF (-1)
#ifndef EOF
# define EOF (-1)
#endif
pic_value
pic_open_port(pic_state *pic, xFILE *file)
pic_funopen(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 *))
{
struct file *fp;
struct port *port;
for (fp = pic->files; fp < pic->files + PIC_OPEN_MAX; fp++)
if ((fp->flag & (FILE_READ | FILE_WRITE)) == 0)
break; /* found free slot */
if (fp >= pic->files + PIC_OPEN_MAX) /* no free slots */
pic_error(pic, "too many files open", 0);
fp->cnt = 0;
fp->base = NULL;
fp->flag = read? FILE_READ : FILE_WRITE;
fp->vtable.cookie = cookie;
fp->vtable.read = read;
fp->vtable.write = write;
fp->vtable.seek = seek;
fp->vtable.close = close;
port = (struct port *)pic_obj_alloc(pic, sizeof(struct port), PIC_TYPE_PORT);
port->file = file;
port->file = fp;
return pic_obj_value(port);
}
xFILE *
pic_fileno(pic_state *PIC_UNUSED(pic), pic_value port)
int
pic_fclose(pic_state *pic, pic_value port)
{
return pic_port_ptr(pic, port)->file;
struct file *fp = pic_port_ptr(pic, port)->file;
pic_fflush(pic, port);
fp->flag = 0;
if (fp->base != fp->buf)
pic_free(pic, fp->base);
return fp->vtable.close(pic, fp->vtable.cookie);
}
void
pic_close_port(pic_state *pic, pic_value port)
pic_clearerr(pic_state *PIC_UNUSED(pic), pic_value port)
{
xFILE *file = pic_fileno(pic, port);
struct file *fp = pic_port_ptr(pic, port)->file;
if (file->flag == 0) {
return;
fp->flag &= ~(FILE_EOF | FILE_ERR);
}
int
pic_feof(pic_state *PIC_UNUSED(pic), pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
return (fp->flag & FILE_EOF) != 0;
}
int
pic_ferror(pic_state *PIC_UNUSED(pic), pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
return (fp->flag & FILE_ERR) != 0;
}
static int
fillbuf(pic_state *pic, struct file *fp)
{
int bufsize;
if ((fp->flag & (FILE_READ|FILE_EOF|FILE_ERR)) != FILE_READ)
return EOF;
if (fp->base == NULL) {
if ((fp->flag & FILE_UNBUF) == 0) {
/* no buffer yet */
if ((fp->base = pic_malloc(pic, PIC_BUFSIZ)) == NULL) {
/* can't get buffer, try unbuffered */
fp->flag |= FILE_UNBUF;
}
if (xfclose(pic, file) == EOF) {
pic_error(pic, "close-port: failure", 0);
}
if (fp->flag & FILE_UNBUF) {
fp->base = fp->buf;
}
}
bufsize = (fp->flag & FILE_UNBUF) ? sizeof(fp->buf) : PIC_BUFSIZ;
fp->ptr = fp->base;
fp->cnt = fp->vtable.read(pic, fp->vtable.cookie, fp->ptr, bufsize);
if (--fp->cnt < 0) {
if (fp->cnt == -1)
fp->flag |= FILE_EOF;
else
fp->flag |= FILE_ERR;
fp->cnt = 0;
return EOF;
}
return (unsigned char) *fp->ptr++;
}
static int
flushbuf(pic_state *pic, int x, struct file *fp)
{
int num_written=0, bufsize=0;
char c = x;
if ((fp->flag & (FILE_WRITE|FILE_EOF|FILE_ERR)) != FILE_WRITE)
return EOF;
if (fp->base == NULL && ((fp->flag & FILE_UNBUF) == 0)) {
/* no buffer yet */
if ((fp->base = pic_malloc(pic, PIC_BUFSIZ)) == NULL) {
/* couldn't allocate a buffer, so try unbuffered */
fp->flag |= FILE_UNBUF;
} else {
fp->ptr = fp->base;
fp->cnt = PIC_BUFSIZ - 1;
}
}
if (fp->flag & FILE_UNBUF) {
/* unbuffered write */
fp->ptr = fp->base = NULL;
fp->cnt = 0;
if (x == EOF)
return EOF;
num_written = fp->vtable.write(pic, fp->vtable.cookie, (const char *) &c, 1);
bufsize = 1;
} else {
/* buffered write */
assert(fp->ptr);
if (x != EOF) {
*fp->ptr++ = (unsigned char) c;
}
bufsize = (int)(fp->ptr - fp->base);
while(bufsize - num_written > 0) {
int t;
t = fp->vtable.write(pic, fp->vtable.cookie, fp->base + num_written, bufsize - num_written);
if (t < 0)
break;
num_written += t;
}
fp->ptr = fp->base;
fp->cnt = PIC_BUFSIZ - 1;
}
if (num_written == bufsize) {
return x;
} else {
fp->flag |= FILE_ERR;
return EOF;
}
}
static int
fflush_(pic_state *pic, struct file *fp)
{
int retval;
int i;
retval = 0;
if (fp == NULL) {
/* flush all output streams */
for (i = 0; i < PIC_OPEN_MAX; i++) {
if ((pic->files[i].flag & FILE_WRITE) && (fflush_(pic, &pic->files[i]) == -1))
retval = -1;
}
} else {
if ((fp->flag & FILE_WRITE) == 0)
return -1;
flushbuf(pic, EOF, fp);
if (fp->flag & FILE_ERR)
retval = -1;
}
return retval;
}
int
pic_fflush(pic_state *pic, pic_value port)
{
if (! pic_port_p(pic, port)) {
return fflush_(pic, NULL);
} else {
return fflush_(pic, pic_port_ptr(pic, port)->file);
}
}
#define getc_(pic, p) \
((--(p)->cnt >= 0) \
? (unsigned char) *(p)->ptr++ \
: fillbuf((pic), p))
#define putc_(pic, x, p) \
((--(p)->cnt >= 0 && !(((p)->flag & FILE_LNBUF) && (x) == '\n')) \
? *(p)->ptr++ = (x) \
: flushbuf((pic), (x), (p)))
int
pic_fputc(pic_state *pic, int x, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
return putc_(pic, x, fp);
}
int
pic_fgetc(pic_state *pic, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
return getc_(pic, fp);
}
int
pic_fputs(pic_state *pic, const char *s, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
const char *ptr = s;
while(*ptr != '\0') {
if (putc_(pic, *ptr, fp) == EOF)
return EOF;
++ptr;
}
return (int)(ptr - s);
}
char *
pic_fgets(pic_state *pic, char *s, int size, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
int c = 0;
char *buf;
pic_fflush(pic, pic_false_value(pic));
if (size == 0) {
return NULL;
}
buf = s;
while (--size > 0 && (c = getc_(pic, fp)) != EOF) {
if ((*buf++ = c) == '\n')
break;
}
*buf = '\0';
return (c == EOF && buf == s) ? NULL : s;
}
int
pic_ungetc(pic_state *PIC_UNUSED(pic), int c, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
unsigned char uc = c;
if (c == EOF || fp->base == fp->ptr) {
return EOF;
}
fp->cnt++;
return *--fp->ptr = uc;
}
size_t
pic_fread(pic_state *pic, void *ptr, size_t size, size_t count, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
char *bptr = ptr;
long nbytes;
int c;
nbytes = size * count;
while (nbytes > fp->cnt) {
memcpy(bptr, fp->ptr, fp->cnt);
fp->ptr += fp->cnt;
bptr += fp->cnt;
nbytes -= fp->cnt;
if ((c = fillbuf(pic, fp)) == EOF) {
return (size * count - nbytes) / size;
} else {
pic_ungetc(pic, c, port);
}
}
memcpy(bptr, fp->ptr, nbytes);
fp->ptr += nbytes;
fp->cnt -= nbytes;
return count;
}
size_t
pic_fwrite(pic_state *pic, const void *ptr, size_t size, size_t count, pic_value port)
{
struct file *fp = pic_port_ptr(pic, port)->file;
const char *bptr = ptr;
long nbytes;
nbytes = size * count;
while (nbytes > fp->cnt) {
memcpy(fp->ptr, bptr, fp->cnt);
fp->ptr += fp->cnt;
bptr += fp->cnt;
nbytes -= fp->cnt;
if (flushbuf(pic, EOF, fp) == EOF) {
return (size * count - nbytes) / size;
}
}
memcpy(fp->ptr, bptr, nbytes);
fp->ptr += nbytes;
fp->cnt -= nbytes;
return count;
}
long
pic_fseek(pic_state *pic, pic_value port, long offset, int whence)
{
struct file *fp = pic_port_ptr(pic, port)->file;
long s;
pic_fflush(pic, port);
fp->ptr = fp->base;
fp->cnt = 0;
if ((s = fp->vtable.seek(pic, fp->vtable.cookie, offset, whence)) != 0)
return s;
fp->flag &= ~FILE_EOF;
return 0;
}
#if PIC_USE_STDIO
static int
file_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size) {
FILE *file = cookie;
int r;
if (! cookie)
return 0;
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;
if (! cookie)
return size;
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) {
if (! cookie)
return 0;
switch (whence) {
case PIC_SEEK_CUR:
whence = SEEK_CUR;
break;
case PIC_SEEK_SET:
whence = SEEK_SET;
break;
case PIC_SEEK_END:
whence = SEEK_END;
break;
}
if (fseek(cookie, pos, whence) == 0) {
return ftell(cookie);
}
return -1;
}
static int
file_close(pic_state *PIC_UNUSED(pic), void *cookie) {
return fclose(cookie);
}
pic_value
pic_fopen(pic_state *pic, FILE *fp, const char *mode) {
if (*mode == 'r') {
return pic_funopen(pic, fp, file_read, 0, file_seek, file_close);
} else {
return pic_funopen(pic, fp, 0, file_write, file_seek, file_close);
}
}
#else
static int
null_read(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), char *PIC_UNUSED(ptr), int PIC_UNUSED(size)) {
return 0;
}
static int
null_write(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), const char *PIC_UNUSED(ptr), int size) {
return size;
}
static long
null_seek(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence)) {
return 0;
}
static int
null_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie)) {
return 0;
}
static pic_value
pic_fopen_null(pic_state *PIC_UNUSED(pic), const char *mode)
{
switch (*mode) {
case 'r':
return pic_funopen(pic, 0, null_read, 0, null_seek, null_close);
default:
return pic_funopen(pic, 0, 0, null_write, null_seek, null_close);
}
}
#endif
typedef struct { char *buf; long pos, end, capa; } xbuf_t;
static int
string_read(pic_state *PIC_UNUSED(pic), void *cookie, char *ptr, int size)
{
xbuf_t *m = cookie;
if (size > (int)(m->end - m->pos))
size = (int)(m->end - m->pos);
memcpy(ptr, m->buf + m->pos, size);
m->pos += size;
return size;
}
static int
string_write(pic_state *pic, void *cookie, const char *ptr, int size)
{
xbuf_t *m = cookie;
if (m->pos + size >= m->capa) {
m->capa = (m->pos + size) * 2;
m->buf = pic_realloc(pic, m->buf, m->capa);
}
memcpy(m->buf + m->pos, ptr, size);
m->pos += size;
if (m->end < m->pos)
m->end = m->pos;
return size;
}
static long
string_seek(pic_state *PIC_UNUSED(pic), void *cookie, long pos, int whence)
{
xbuf_t *m = cookie;
switch (whence) {
case PIC_SEEK_SET:
m->pos = pos;
break;
case PIC_SEEK_CUR:
m->pos += pos;
break;
case PIC_SEEK_END:
m->pos = m->end + pos;
break;
}
return m->pos;
}
static int
string_close(pic_state *pic, void *cookie)
{
xbuf_t *m = cookie;
pic_free(pic, m->buf);
pic_free(pic, m);
return 0;
}
pic_value
pic_fmemopen(pic_state *pic, const char *data, int size, const char *mode)
{
xbuf_t *m;
m = pic_malloc(pic, sizeof(xbuf_t));
m->buf = pic_malloc(pic, size);
m->pos = 0;
m->end = size;
m->capa = size;
if (*mode == 'r') {
memcpy(m->buf, data, size);
return pic_funopen(pic, m, string_read, NULL, string_seek, string_close);
} else {
return pic_funopen(pic, m, NULL, string_write, string_seek, string_close);
}
}
int
pic_fgetbuf(pic_state *pic, pic_value port, const char **buf, int *len)
{
struct file *fp = pic_port_ptr(pic, port)->file;
xbuf_t *s;
pic_fflush(pic, port);
if (fp->vtable.write != string_write) {
return -1;
}
s = fp->vtable.cookie;
*len = s->end;
*buf = s->buf;
return 0;
}
static pic_value
@ -47,7 +551,7 @@ pic_port_input_port_p(pic_state *pic)
pic_get_args(pic, "o", &v);
if (pic_port_p(pic, v) && (pic_fileno(pic, v)->flag & X_READ) != 0) {
if (pic_port_p(pic, v) && (pic_port_ptr(pic, v)->file->flag & FILE_READ) != 0) {
return pic_true_value(pic);
} else {
return pic_false_value(pic);
@ -61,7 +565,7 @@ pic_port_output_port_p(pic_state *pic)
pic_get_args(pic, "o", &v);
if (pic_port_p(pic, v) && (pic_fileno(pic, v)->flag & X_WRITE) != 0) {
if (pic_port_p(pic, v) && (pic_port_ptr(pic, v)->file->flag & FILE_WRITE) != 0) {
return pic_true_value(pic);
}
else {
@ -104,7 +608,7 @@ pic_port_port_open_p(pic_state *pic)
pic_get_args(pic, "p", &port);
return pic_bool_value(pic, pic_fileno(pic, port)->flag != 0);
return pic_bool_value(pic, pic_port_ptr(pic, port)->file->flag != 0);
}
static pic_value
@ -114,21 +618,22 @@ pic_port_close_port(pic_state *pic)
pic_get_args(pic, "p", &port);
pic_close_port(pic, port);
pic_fclose(pic, port);
return pic_undef_value(pic);
}
#define assert_port_profile(port, flags, caller) do { \
if ((pic_fileno(pic, port)->flag & (flags)) != (flags)) { \
int flag = pic_port_ptr(pic, port)->file->flag; \
if ((flag & (flags)) != (flags)) { \
switch (flags) { \
case X_WRITE: \
case FILE_WRITE: \
pic_error(pic, caller ": output port required", 0); \
case X_READ: \
case FILE_READ: \
pic_error(pic, caller ": input port required", 0); \
} \
} \
if (pic_fileno(pic, port)->flag == 0) { \
if (flag == 0) { \
pic_error(pic, caller ": open port required", 0); \
} \
} while (0)
@ -141,7 +646,7 @@ pic_port_open_input_bytevector(pic_state *pic)
pic_get_args(pic, "b", &buf, &len);
return pic_open_port(pic, xfopen_buf(pic, (char *)buf, len, "r"));
return pic_fmemopen(pic, (char *)buf, len, "r");
}
static pic_value
@ -149,7 +654,7 @@ pic_port_open_output_bytevector(pic_state *pic)
{
pic_get_args(pic, "");
return pic_open_port(pic, xfopen_buf(pic, NULL, 0, "w"));
return pic_fmemopen(pic, NULL, 0, "w");
}
static pic_value
@ -161,9 +666,9 @@ pic_port_get_output_bytevector(pic_state *pic)
pic_get_args(pic, "|p", &port);
assert_port_profile(port, X_WRITE, "get-output-bytevector");
assert_port_profile(port, FILE_WRITE, "get-output-bytevector");
if (xfget_buf(pic, pic_fileno(pic, port), &buf, &len) < 0) {
if (pic_fgetbuf(pic, port, &buf, &len) < 0) {
pic_error(pic, "port was not created by open-output-bytevector", 0);
}
return pic_blob_value(pic, (unsigned char *)buf, len);
@ -175,8 +680,8 @@ pic_port_read_u8(pic_state *pic){
int c;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, X_READ, "read-u8");
if ((c = xfgetc(pic, pic_fileno(pic, port))) == EOF) {
assert_port_profile(port, FILE_READ, "read-u8");
if ((c = pic_fgetc(pic, port)) == EOF) {
return pic_eof_object(pic);
}
@ -191,14 +696,14 @@ pic_port_peek_u8(pic_state *pic)
pic_get_args(pic, "|p", &port);
assert_port_profile(port, X_READ, "peek-u8");
assert_port_profile(port, FILE_READ, "peek-u8");
c = xfgetc(pic, pic_fileno(pic, port));
c = pic_fgetc(pic, port);
if (c == EOF) {
return pic_eof_object(pic);
}
else {
xungetc(pic, c, pic_fileno(pic, port));
pic_ungetc(pic, c, port);
return pic_int_value(pic, c);
}
}
@ -210,7 +715,7 @@ pic_port_u8_ready_p(pic_state *pic)
pic_get_args(pic, "|p", &port);
assert_port_profile(port, X_READ, "u8-ready?");
assert_port_profile(port, FILE_READ, "u8-ready?");
return pic_true_value(pic); /* FIXME: always returns #t */
}
@ -225,11 +730,11 @@ pic_port_read_bytevector(pic_state *pic)
pic_get_args(pic, "i|p", &k, &port);
assert_port_profile(port, X_READ, "read-bytevector");
assert_port_profile(port, FILE_READ, "read-bytevector");
buf = pic_blob(pic, pic_blob_value(pic, NULL, k), NULL);
i = xfread(pic, buf, sizeof(char), k, pic_fileno(pic, port));
i = pic_fread(pic, buf, sizeof(char), k, port);
if (i == 0) {
return pic_eof_object(pic);
}
@ -255,9 +760,9 @@ pic_port_read_bytevector_ip(pic_state *pic)
}
VALID_RANGE(pic, len, start, end);
assert_port_profile(port, X_READ, "read-bytevector!");
assert_port_profile(port, FILE_READ, "read-bytevector!");
i = xfread(pic, buf + start, 1, end - start, pic_fileno(pic, port));
i = pic_fread(pic, buf + start, 1, end - start, port);
if (i == 0) {
return pic_eof_object(pic);
}
@ -272,9 +777,9 @@ pic_port_write_u8(pic_state *pic)
pic_get_args(pic, "i|p", &i, &port);
assert_port_profile(port, X_WRITE, "write-u8");
assert_port_profile(port, FILE_WRITE, "write-u8");
xfputc(pic, i, pic_fileno(pic, port));
pic_fputc(pic, i, port);
return pic_undef_value(pic);
}
@ -297,11 +802,11 @@ pic_port_write_bytevector(pic_state *pic)
}
VALID_RANGE(pic, len, start, end);
assert_port_profile(port, X_WRITE, "write-bytevector");
assert_port_profile(port, FILE_WRITE, "write-bytevector");
done = 0;
while (done < end - start) {
done += xfwrite(pic, buf + start + done, 1, end - start - done, pic_fileno(pic, port));
done += pic_fwrite(pic, buf + start + done, 1, end - start - done, port);
/* FIXME: error check... */
}
return pic_undef_value(pic);
@ -314,9 +819,9 @@ pic_port_flush(pic_state *pic)
pic_get_args(pic, "|p", &port);
assert_port_profile(port, X_WRITE, "flush-output-port");
assert_port_profile(port, FILE_WRITE, "flush-output-port");
xfflush(pic, pic_fileno(pic, port));
pic_fflush(pic, port);
return pic_undef_value(pic);
}
@ -330,17 +835,22 @@ coerce_port(pic_state *pic)
return port;
}
#define DEFINE_PORT(pic, name, file) \
pic_defvar(pic, name, pic_open_port(pic, file), coerce)
#if PIC_USE_STDIO
# define DEFINE_PORT(pic, name, file, mode) \
pic_defvar(pic, name, pic_fopen(pic, file, mode), coerce)
#else
# define DEFINE_PORT(pic, name, file, mode) \
pic_defvar(pic, name, pic_fopen_null(pic, mode), coerce)
#endif
void
pic_init_port(pic_state *pic)
{
pic_value coerce = pic_lambda(pic, coerce_port, 0);
DEFINE_PORT(pic, "current-input-port", xstdin);
DEFINE_PORT(pic, "current-output-port", xstdout);
DEFINE_PORT(pic, "current-error-port", xstderr);
DEFINE_PORT(pic, "current-input-port", stdin, "r");
DEFINE_PORT(pic, "current-output-port", stdout, "w");
DEFINE_PORT(pic, "current-error-port", stderr, "w");
pic_defun(pic, "port?", pic_port_port_p);
pic_defun(pic, "input-port?", pic_port_input_port_p);

245
extlib/benz/read.c
View File

@ -20,13 +20,13 @@ struct reader_control {
#define CASE_DEFAULT 0
#define CASE_FOLD 1
typedef pic_value (*pic_reader_t)(pic_state *, xFILE *file, int c, struct reader_control *);
typedef pic_value (*pic_reader_t)(pic_state *, pic_value port, int c, struct reader_control *);
static pic_reader_t reader_table[256];
static pic_reader_t reader_dispatch[256];
static pic_value read_value(pic_state *pic, xFILE *file, int c, struct reader_control *p);
static pic_value read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p);
static pic_value read_value(pic_state *pic, pic_value port, int c, struct reader_control *p);
static pic_value read_nullable(pic_state *pic, pic_value port, int c, struct reader_control *p);
PIC_NORETURN static void
read_error(pic_state *pic, const char *msg, pic_value irritants)
@ -35,39 +35,39 @@ read_error(pic_state *pic, const char *msg, pic_value irritants)
}
static int
skip(pic_state *pic, xFILE *file, int c)
skip(pic_state *pic, pic_value port, int c)
{
while (isspace(c)) {
c = xfgetc(pic, file);
c = pic_fgetc(pic, port);
}
return c;
}
static int
next(pic_state *pic, xFILE *file)
next(pic_state *pic, pic_value port)
{
return xfgetc(pic, file);
return pic_fgetc(pic, port);
}
static int
peek(pic_state *pic, xFILE *file)
peek(pic_state *pic, pic_value port)
{
int c;
xungetc(pic, (c = xfgetc(pic, file)), file);
pic_ungetc(pic, (c = pic_fgetc(pic, port)), port);
return c;
}
static bool
expect(pic_state *pic, xFILE *file, const char *str)
expect(pic_state *pic, pic_value port, const char *str)
{
int c;
while ((c = (int)*str++) != 0) {
if (c != peek(pic, file))
if (c != peek(pic, port))
return false;
next(pic, file);
next(pic, port);
}
return true;
@ -89,26 +89,26 @@ case_fold(int c, struct reader_control *p)
}
static pic_value
read_comment(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_comment(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
do {
c = next(pic, file);
c = next(pic, port);
} while (! (c == EOF || c == '\n'));
return pic_invalid_value(pic);
}
static pic_value
read_block_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
read_block_comment(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
{
int x, y;
int i = 1;
y = next(pic, file);
y = next(pic, port);
while (y != EOF && i > 0) {
x = y;
y = next(pic, file);
y = next(pic, port);
if (x == '|' && y == '#') {
i--;
}
@ -121,88 +121,88 @@ read_block_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader
}
static pic_value
read_datum_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_datum_comment(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
read_value(pic, file, next(pic, file), p);
read_value(pic, port, next(pic, port), p);
return pic_invalid_value(pic);
}
static pic_value
read_directive(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_directive(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
switch (peek(pic, file)) {
switch (peek(pic, port)) {
case 'n':
if (expect(pic, file, "no-fold-case")) {
if (expect(pic, port, "no-fold-case")) {
p->typecase = CASE_DEFAULT;
return pic_invalid_value(pic);
}
break;
case 'f':
if (expect(pic, file, "fold-case")) {
if (expect(pic, port, "fold-case")) {
p->typecase = CASE_FOLD;
return pic_invalid_value(pic);
}
break;
}
return read_comment(pic, file, c, p);
return read_comment(pic, port, c, p);
}
static pic_value
read_quote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_quote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read_value(pic, file, next(pic, file), p));
return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read_value(pic, port, next(pic, port), p));
}
static pic_value
read_quasiquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_quasiquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read_value(pic, file, next(pic, file), p));
return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read_value(pic, port, next(pic, port), p));
}
static pic_value
read_unquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_unquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
pic_value tag;
if (peek(pic, file) == '@') {
if (peek(pic, port) == '@') {
tag = pic_intern_lit(pic, "unquote-splicing");
next(pic, file);
next(pic, port);
} else {
tag = pic_intern_lit(pic, "unquote");
}
return pic_list(pic, 2, tag, read_value(pic, file, next(pic, file), p));
return pic_list(pic, 2, tag, read_value(pic, port, next(pic, port), p));
}
static pic_value
read_syntax_quote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_syntax_quote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read_value(pic, file, next(pic, file), p));
return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read_value(pic, port, next(pic, port), p));
}
static pic_value
read_syntax_quasiquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_syntax_quasiquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read_value(pic, file, next(pic, file), p));
return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read_value(pic, port, next(pic, port), p));
}
static pic_value
read_syntax_unquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
read_syntax_unquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
{
pic_value tag;
if (peek(pic, file) == '@') {
if (peek(pic, port) == '@') {
tag = pic_intern_lit(pic, "syntax-unquote-splicing");
next(pic, file);
next(pic, port);
} else {
tag = pic_intern_lit(pic, "syntax-unquote");
}
return pic_list(pic, 2, tag, read_value(pic, file, next(pic, file), p));
return pic_list(pic, 2, tag, read_value(pic, port, next(pic, port), p));
}
static pic_value
read_atom(pic_state *pic, xFILE *file, int c, struct reader_control *p) {
read_atom(pic_state *pic, pic_value port, int c, struct reader_control *p) {
int len;
char *buf;
pic_value str;
@ -212,8 +212,8 @@ read_atom(pic_state *pic, xFILE *file, int c, struct reader_control *p) {
buf[0] = case_fold(c, p);
buf[1] = 0;
while (! isdelim(peek(pic, file))) {
c = next(pic, file);
while (! isdelim(peek(pic, port))) {
c = next(pic, port);
len += 1;
buf = pic_realloc(pic, buf, len + 1);
buf[len - 1] = case_fold(c, p);
@ -227,15 +227,15 @@ read_atom(pic_state *pic, xFILE *file, int c, struct reader_control *p) {
}
static pic_value
read_symbol(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_symbol(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
return pic_intern(pic, read_atom(pic, file, c, p));
return pic_intern(pic, read_atom(pic, port, c, p));
}
static pic_value
read_number(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_number(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
pic_value str = read_atom(pic, file, c, p), num;
pic_value str = read_atom(pic, port, c, p), num;
num = pic_funcall(pic, "picrin.base", "string->number", 1, str);
if (! pic_false_p(pic, num)) {
@ -245,7 +245,7 @@ read_number(pic_state *pic, xFILE *file, int c, struct reader_control *p)
}
static unsigned
read_uinteger(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_uinteger(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
unsigned u = 0;
@ -254,18 +254,18 @@ read_uinteger(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNU
}
u = c - '0';
while (isdigit(c = peek(pic, file))) {
u = u * 10 + next(pic, file) - '0';
while (isdigit(c = peek(pic, port))) {
u = u * 10 + next(pic, port) - '0';
}
return u;
}
static pic_value
read_true(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_true(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
if ((c = peek(pic, file)) == 'r') {
if (! expect(pic, file, "rue")) {
if ((c = peek(pic, port)) == 'r') {
if (! expect(pic, port, "rue")) {
read_error(pic, "unexpected character while reading #true", pic_nil_value(pic));
}
} else if (! isdelim(c)) {
@ -276,10 +276,10 @@ read_true(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(
}
static pic_value
read_false(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_false(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
if ((c = peek(pic, file)) == 'a') {
if (! expect(pic, file, "alse")) {
if ((c = peek(pic, port)) == 'a') {
if (! expect(pic, port, "alse")) {
read_error(pic, "unexpected character while reading #false", pic_nil_value(pic));
}
} else if (! isdelim(c)) {
@ -290,31 +290,31 @@ read_false(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED
}
static pic_value
read_char(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_char(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
c = next(pic, file);
c = next(pic, port);
if (! isdelim(peek(pic, file))) {
if (! isdelim(peek(pic, port))) {
switch (c) {
default: read_error(pic, "unexpected character after char literal", pic_list(pic, 1, pic_char_value(pic, c)));
case 'a': c = '\a'; if (! expect(pic, file, "larm")) goto fail; break;
case 'b': c = '\b'; if (! expect(pic, file, "ackspace")) goto fail; break;
case 'd': c = 0x7F; if (! expect(pic, file, "elete")) goto fail; break;
case 'e': c = 0x1B; if (! expect(pic, file, "scape")) goto fail; break;
case 'a': c = '\a'; if (! expect(pic, port, "larm")) goto fail; break;
case 'b': c = '\b'; if (! expect(pic, port, "ackspace")) goto fail; break;
case 'd': c = 0x7F; if (! expect(pic, port, "elete")) goto fail; break;
case 'e': c = 0x1B; if (! expect(pic, port, "scape")) goto fail; break;
case 'n':
if ((c = peek(pic, file)) == 'e') {
if ((c = peek(pic, port)) == 'e') {
c = '\n';
if (! expect(pic, file, "ewline"))
if (! expect(pic, port, "ewline"))
goto fail;
} else {
c = '\0';
if (! expect(pic, file, "ull"))
if (! expect(pic, port, "ull"))
goto fail;
}
break;
case 'r': c = '\r'; if (! expect(pic, file, "eturn")) goto fail; break;
case 's': c = ' '; if (! expect(pic, file, "pace")) goto fail; break;
case 't': c = '\t'; if (! expect(pic, file, "ab")) goto fail; break;
case 'r': c = '\r'; if (! expect(pic, port, "eturn")) goto fail; break;
case 's': c = ' '; if (! expect(pic, port, "pace")) goto fail; break;
case 't': c = '\t'; if (! expect(pic, port, "ab")) goto fail; break;
}
}
@ -325,7 +325,7 @@ read_char(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(
}
static pic_value
read_string(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_string(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
char *buf;
int size, cnt;
@ -337,9 +337,9 @@ read_string(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSE
/* TODO: intraline whitespaces */
while ((c = next(pic, file)) != '"') {
while ((c = next(pic, port)) != '"') {
if (c == '\\') {
switch (c = next(pic, file)) {
switch (c = next(pic, port)) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
@ -360,7 +360,7 @@ read_string(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSE
}
static pic_value
read_pipe(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(p))
read_pipe(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
{
char *buf;
int size, cnt;
@ -372,9 +372,9 @@ read_pipe(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(
size = 256;
buf = pic_malloc(pic, size);
cnt = 0;
while ((c = next(pic, file)) != '|') {
while ((c = next(pic, port)) != '|') {
if (c == '\\') {
switch ((c = next(pic, file))) {
switch ((c = next(pic, port))) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
@ -382,7 +382,7 @@ read_pipe(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(
case 'r': c = '\r'; break;
case 'x':
i = 0;
while ((HEX_BUF[i++] = (char)next(pic, file)) != ';') {
while ((HEX_BUF[i++] = (char)next(pic, port)) != ';') {
if (i >= sizeof HEX_BUF)
read_error(pic, "expected ';'", pic_list(pic, 1, pic_char_value(pic, HEX_BUF[sizeof(HEX_BUF) - 1])));
}
@ -404,7 +404,7 @@ read_pipe(pic_state *pic, xFILE *file, int c, struct reader_control *PIC_UNUSED(
}
static pic_value
read_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_blob(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
int nbits, n;
int len;
@ -413,7 +413,7 @@ read_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p)
nbits = 0;
while (isdigit(c = next(pic, file))) {
while (isdigit(c = next(pic, port))) {
nbits = 10 * nbits + c - '0';
}
@ -427,16 +427,16 @@ read_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p)
len = 0;
dat = NULL;
c = next(pic, file);
while ((c = skip(pic, file, c)) != ')') {
n = read_uinteger(pic, file, c, p);
c = next(pic, port);
while ((c = skip(pic, port, c)) != ')') {
n = read_uinteger(pic, port, c, p);
if (n < 0 || (1 << nbits) <= n) {
read_error(pic, "invalid element in bytevector literal", pic_list(pic, 1, pic_int_value(pic, n)));
}
len += 1;
dat = pic_realloc(pic, dat, len);
dat[len - 1] = (unsigned char)n;
c = next(pic, file);
c = next(pic, port);
}
blob = pic_blob_value(pic, dat, len);
@ -446,10 +446,10 @@ read_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p)
}
static pic_value
read_undef_or_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_undef_or_blob(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
if ((c = peek(pic, file)) == 'n') {
if (! expect(pic, file, "ndefined")) {
if ((c = peek(pic, port)) == 'n') {
if (! expect(pic, port, "ndefined")) {
read_error(pic, "unexpected character while reading #undefined", pic_nil_value(pic));
}
return pic_undef_value(pic);
@ -457,28 +457,28 @@ read_undef_or_blob(pic_state *pic, xFILE *file, int c, struct reader_control *p)
if (! isdigit(c)) {
read_error(pic, "expect #undefined or #u8(...), but illegal character given", pic_list(pic, 1, pic_char_value(pic, c)));
}
return read_blob(pic, file, 'u', p);
return read_blob(pic, port, 'u', p);
}
static pic_value
read_pair(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_pair(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
static const int tCLOSE = ')';
pic_value car, cdr;
retry:
c = skip(pic, file, ' ');
c = skip(pic, port, ' ');
if (c == tCLOSE) {
return pic_nil_value(pic);
}
if (c == '.' && isdelim(peek(pic, file))) {
cdr = read_value(pic, file, next(pic, file), p);
if (c == '.' && isdelim(peek(pic, port))) {
cdr = read_value(pic, port, next(pic, port), p);
closing:
if ((c = skip(pic, file, ' ')) != tCLOSE) {
if (pic_invalid_p(pic, read_nullable(pic, file, c, p))) {
if ((c = skip(pic, port, ' ')) != tCLOSE) {
if (pic_invalid_p(pic, read_nullable(pic, port, c, p))) {
goto closing;
}
read_error(pic, "unmatched parenthesis", pic_nil_value(pic));
@ -486,24 +486,24 @@ read_pair(pic_state *pic, xFILE *file, int c, struct reader_control *p)
return cdr;
}
else {
car = read_nullable(pic, file, c, p);
car = read_nullable(pic, port, c, p);
if (pic_invalid_p(pic, car)) {
goto retry;
}
cdr = read_pair(pic, file, '(', p);
cdr = read_pair(pic, port, '(', p);
return pic_cons(pic, car, cdr);
}
}
static pic_value
read_vector(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_vector(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
pic_value list, it, elem, vec;
int i = 0;
list = read_value(pic, file, c, p);
list = read_value(pic, port, c, p);
vec = pic_make_vec(pic, pic_length(pic, list), NULL);
@ -515,7 +515,7 @@ read_vector(pic_state *pic, xFILE *file, int c, struct reader_control *p)
}
static pic_value
read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
read_label_set(pic_state *pic, pic_value port, int i, struct reader_control *p)
{
khash_t(read) *h = &p->labels;
pic_value val;
@ -523,14 +523,14 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
it = kh_put(read, h, i, &ret);
switch ((c = skip(pic, file, ' '))) {
switch ((c = skip(pic, port, ' '))) {
case '(':
{
pic_value tmp;
kh_val(h, it) = val = pic_cons(pic, pic_undef_value(pic), pic_undef_value(pic));
tmp = read_value(pic, file, c, p);
tmp = read_value(pic, port, c, p);
pic_pair_ptr(pic, val)->car = pic_car(pic, tmp);
pic_pair_ptr(pic, val)->cdr = pic_cdr(pic, tmp);
@ -540,7 +540,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
{
bool vect;
if (peek(pic, file) == '(') {
if (peek(pic, port) == '(') {
vect = true;
} else {
vect = false;
@ -551,7 +551,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
kh_val(h, it) = val = pic_make_vec(pic, 0, NULL);
tmp = read_value(pic, file, c, p);
tmp = read_value(pic, port, c, p);
PIC_SWAP(pic_value *, pic_vec_ptr(pic, tmp)->data, pic_vec_ptr(pic, val)->data);
PIC_SWAP(int, pic_vec_ptr(pic, tmp)->len, pic_vec_ptr(pic, val)->len);
@ -562,7 +562,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
}
default:
{
kh_val(h, it) = val = read_value(pic, file, c, p);
kh_val(h, it) = val = read_value(pic, port, c, p);
return val;
}
@ -570,7 +570,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
}
static pic_value
read_label_ref(pic_state *pic, xFILE *PIC_UNUSED(file), int i, struct reader_control *p)
read_label_ref(pic_state *pic, pic_value PIC_UNUSED(port), int i, struct reader_control *p)
{
khash_t(read) *h = &p->labels;
int it;
@ -583,34 +583,34 @@ read_label_ref(pic_state *pic, xFILE *PIC_UNUSED(file), int i, struct reader_con
}
static pic_value
read_label(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_label(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
int i;
i = 0;
do {
i = i * 10 + c - '0';
} while (isdigit(c = next(pic, file)));
} while (isdigit(c = next(pic, port)));
if (c == '=') {
return read_label_set(pic, file, i, p);
return read_label_set(pic, port, i, p);
}
if (c == '#') {
return read_label_ref(pic, file, i, p);
return read_label_ref(pic, port, i, p);
}
read_error(pic, "broken label expression", pic_nil_value(pic));
}
static pic_value
read_unmatch(pic_state *pic, xFILE *PIC_UNUSED(file), int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
read_unmatch(pic_state *pic, pic_value PIC_UNUSED(port), int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
{
read_error(pic, "unmatched parenthesis", pic_nil_value(pic));
}
static pic_value
read_dispatch(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_dispatch(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
c = next(pic, file);
c = next(pic, port);
if (c == EOF) {
read_error(pic, "unexpected EOF", pic_nil_value(pic));
@ -620,13 +620,13 @@ read_dispatch(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c)));
}
return reader_dispatch[c](pic, file, c, p);
return reader_dispatch[c](pic, port, c, p);
}
static pic_value
read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_nullable(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
c = skip(pic, file, c);
c = skip(pic, port, c);
if (c == EOF) {
read_error(pic, "unexpected EOF", pic_nil_value(pic));
@ -636,19 +636,19 @@ read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c)));
}
return reader_table[c](pic, file, c, p);
return reader_table[c](pic, port, c, p);
}
static pic_value
read_value(pic_state *pic, xFILE *file, int c, struct reader_control *p)
read_value(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
pic_value val;
retry:
val = read_nullable(pic, file, c, p);
val = read_nullable(pic, port, c, p);
if (pic_invalid_p(pic, val)) {
c = next(pic, file);
c = next(pic, port);
goto retry;
}
@ -724,15 +724,14 @@ pic_read(pic_state *pic, pic_value port)
struct reader_control p;
size_t ai = pic_enter(pic);
pic_value val;
xFILE *file = pic_fileno(pic, port);
int c;
pic_value e;
reader_init(pic, &p);
pic_try {
while ((c = skip(pic, file, next(pic, file))) != EOF) {
val = read_nullable(pic, file, c, &p);
while ((c = skip(pic, port, next(pic, port))) != EOF) {
val = read_nullable(pic, port, c, &p);
if (! pic_invalid_p(pic, val)) {
break;
@ -755,18 +754,18 @@ pic_read(pic_state *pic, pic_value port)
pic_value
pic_read_cstr(pic_state *pic, const char *str)
{
pic_value port = pic_open_port(pic, xfopen_buf(pic, str, strlen(str), "r"));
pic_value port = pic_fmemopen(pic, str, strlen(str), "r");
pic_value form, e;
pic_try {
form = pic_read(pic, port);
}
pic_catch(e) {
pic_close_port(pic, port);
pic_fclose(pic, port);
pic_raise(pic, e);
}
pic_close_port(pic, port);
pic_fclose(pic, port);
return form;
}

15
extlib/benz/state.c
View File

@ -242,17 +242,6 @@ pic_open(pic_allocf allocf, void *userdata)
/* file pool */
memset(pic->files, 0, sizeof pic->files);
#if PIC_USE_STDIO
xfopen_file(pic, stdin, "r");
xfopen_file(pic, stdout, "w");
xfopen_file(pic, stderr, "w");
pic->files[1].flag |= X_LNBUF;
pic->files[2].flag |= X_UNBUF;
#else
xfopen_null(pic, "r");
xfopen_null(pic, "w");
xfopen_null(pic, "w");
#endif
/* root tables */
pic->globals = pic_make_weak(pic);
@ -308,8 +297,8 @@ pic_close(pic_state *pic)
/* free all heap objects */
pic_gc(pic);
/* flush all xfiles */
xfflush(pic, NULL);
/* flush all files */
pic_fflush(pic, pic_false_value(pic));
/* free heaps */
pic_heap_close(pic, pic->heap);

11
extlib/benz/string.c
View File

@ -232,17 +232,16 @@ pic_strf_value(pic_state *pic, const char *fmt, ...)
pic_value
pic_vstrf_value(pic_state *pic, const char *fmt, va_list ap)
{
pic_value str;
xFILE *file;
pic_value str, port;
const char *buf;
int len;
file = xfopen_buf(pic, NULL, 0, "w");
port = pic_fmemopen(pic, NULL, 0, "w");
xvfprintf(pic, file, fmt, ap);
xfget_buf(pic, file, &buf, &len);
pic_vfprintf(pic, port, fmt, ap);
pic_fgetbuf(pic, port, &buf, &len);
str = pic_str_value(pic, buf, len);
xfclose(pic, file);
pic_fclose(pic, port);
return str;
}

396
extlib/benz/write.c
View File

@ -6,8 +6,6 @@
#include "picrin/extra.h"
#include "picrin/private/object.h"
#if PIC_USE_WRITE
struct writer_control {
int mode;
int op;
@ -23,6 +21,135 @@ struct writer_control {
#define OP_WRITE_SHARED 2
#define OP_WRITE_SIMPLE 3
#if PIC_USE_WRITE
static void write_value(pic_state *pic, pic_value obj, pic_value port, int mode, int op);
#endif
static void
print_int(pic_state *pic, pic_value port, long x, int base)
{
static const char digits[] = "0123456789abcdef";
char buf[20];
int i, neg;
neg = 0;
if (x < 0) {
neg = 1;
x = -x;
}
i = 0;
do {
buf[i++] = digits[x % base];
} while ((x /= base) != 0);
if (neg) {
buf[i++] = '-';
}
while (i-- > 0) {
pic_fputc(pic, buf[i], port);
}
}
int
pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap)
{
const char *p;
char *sval;
int ival;
void *vp;
long start = pic_fseek(pic, port, 0, PIC_SEEK_CUR);
for (p = fmt; *p; p++) {
#if PIC_USE_WRITE
if (*p == '~') {
switch (*++p) {
default:
pic_fputc(pic, *(p-1), port);
break;
case '%':
pic_fputc(pic, '\n', port);
break;
case 'a':
write_value(pic, va_arg(ap, pic_value), port, DISPLAY_MODE, OP_WRITE);
break;
case 's':
write_value(pic, va_arg(ap, pic_value), port, WRITE_MODE, OP_WRITE);
break;
}
continue;
}
#endif
if (*p != '%') {
pic_fputc(pic, *p, port);
continue;
}
switch (*++p) {
case 'd':
case 'i':
ival = va_arg(ap, int);
print_int(pic, port, ival, 10);
break;
case 'f': {
char buf[64];
PIC_DOUBLE_TO_CSTRING(va_arg(ap, double), buf);
pic_fputs(pic, buf, port);
break;
}
case 'c':
ival = va_arg(ap, int);
pic_fputc(pic, ival, port);
break;
case 's':
sval = va_arg(ap, char*);
pic_fputs(pic, sval, port);
break;
case 'p':
vp = va_arg(ap, void*);
pic_fputs(pic, "0x", port);
print_int(pic, port, (long)vp, 16);
break;
case '%':
pic_fputc(pic, *(p-1), port);
break;
default:
pic_fputc(pic, '%', port);
pic_fputc(pic, *(p-1), port);
break;
}
}
return pic_fseek(pic, port, 0, PIC_SEEK_CUR) - start;
}
int
pic_fprintf(pic_state *pic, pic_value port, const char *fmt, ...)
{
va_list ap;
int n;
va_start(ap, fmt);
n = pic_vfprintf(pic, port, fmt, ap);
va_end(ap);
return n;
}
int
pic_printf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
int n;
va_start(ap, fmt);
n = pic_vfprintf(pic, pic_stdout(pic), fmt, ap);
va_end(ap);
return n;
}
#if PIC_USE_WRITE
static void
writer_control_init(pic_state *pic, struct writer_control *p, int mode, int op)
{
@ -100,189 +227,189 @@ is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) {
}
static void
write_blob(pic_state *pic, pic_value blob, xFILE *file)
write_blob(pic_state *pic, pic_value blob, pic_value port)
{
const unsigned char *buf;
int len, i;
buf = pic_blob(pic, blob, &len);
xfprintf(pic, file, "#u8(");
pic_fprintf(pic, port, "#u8(");
for (i = 0; i < len; ++i) {
xfprintf(pic, file, "%d", buf[i]);
pic_fprintf(pic, port, "%d", buf[i]);
if (i + 1 < len) {
xfprintf(pic, file, " ");
pic_fprintf(pic, port, " ");
}
}
xfprintf(pic, file, ")");
pic_fprintf(pic, port, ")");
}
static void
write_char(pic_state *pic, pic_value ch, xFILE *file, struct writer_control *p)
write_char(pic_state *pic, pic_value ch, pic_value port, struct writer_control *p)
{
char c = pic_char(pic, ch);
if (p->mode == DISPLAY_MODE) {
xfputc(pic, c, file);
pic_fputc(pic, c, port);
return;
}
switch (c) {
default: xfprintf(pic, file, "#\\%c", c); break;
case '\a': xfprintf(pic, file, "#\\alarm"); break;
case '\b': xfprintf(pic, file, "#\\backspace"); break;
case 0x7f: xfprintf(pic, file, "#\\delete"); break;
case 0x1b: xfprintf(pic, file, "#\\escape"); break;
case '\n': xfprintf(pic, file, "#\\newline"); break;
case '\r': xfprintf(pic, file, "#\\return"); break;
case ' ': xfprintf(pic, file, "#\\space"); break;
case '\t': xfprintf(pic, file, "#\\tab"); break;
default: pic_fprintf(pic, port, "#\\%c", c); break;
case '\a': pic_fprintf(pic, port, "#\\alarm"); break;
case '\b': pic_fprintf(pic, port, "#\\backspace"); break;
case 0x7f: pic_fprintf(pic, port, "#\\delete"); break;
case 0x1b: pic_fprintf(pic, port, "#\\escape"); break;
case '\n': pic_fprintf(pic, port, "#\\newline"); break;
case '\r': pic_fprintf(pic, port, "#\\return"); break;
case ' ': pic_fprintf(pic, port, "#\\space"); break;
case '\t': pic_fprintf(pic, port, "#\\tab"); break;
}
}
static void
write_str(pic_state *pic, pic_value str, xFILE *file, struct writer_control *p)
write_str(pic_state *pic, pic_value str, pic_value port, struct writer_control *p)
{
int i;
const char *cstr = pic_str(pic, str);
if (p->mode == DISPLAY_MODE) {
xfprintf(pic, file, "%s", pic_str(pic, str));
pic_fprintf(pic, port, "%s", pic_str(pic, str));
return;
}
xfprintf(pic, file, "\"");
pic_fprintf(pic, port, "\"");
for (i = 0; i < pic_str_len(pic, str); ++i) {
if (cstr[i] == '"' || cstr[i] == '\\') {
xfputc(pic, '\\', file);
pic_fputc(pic, '\\', port);
}
xfputc(pic, cstr[i], file);
pic_fputc(pic, cstr[i], port);
}
xfprintf(pic, file, "\"");
pic_fprintf(pic, port, "\"");
}
static void
write_float(pic_state *pic, pic_value flo, xFILE *file)
write_float(pic_state *pic, pic_value flo, pic_value port)
{
double f = pic_float(pic, flo);
if (f != f) {
xfprintf(pic, file, "+nan.0");
pic_fprintf(pic, port, "+nan.0");
} else if (f == 1.0 / 0.0) {
xfprintf(pic, file, "+inf.0");
pic_fprintf(pic, port, "+inf.0");
} else if (f == -1.0 / 0.0) {
xfprintf(pic, file, "-inf.0");
pic_fprintf(pic, port, "-inf.0");
} else {
xfprintf(pic, file, "%f", f);
pic_fprintf(pic, port, "%f", f);
}
}
static void write_core(pic_state *, pic_value, xFILE *, struct writer_control *);
static void write_core(pic_state *, pic_value, pic_value port, struct writer_control *p);
static void
write_pair_help(pic_state *pic, pic_value pair, xFILE *file, struct writer_control *p)
write_pair_help(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
{
pic_value cdr = pic_cdr(pic, pair);
write_core(pic, pic_car(pic, pair), file, p);
write_core(pic, pic_car(pic, pair), port, p);
if (pic_nil_p(pic, cdr)) {
return;
}
else if (pic_pair_p(pic, cdr) && ! is_shared_object(pic, cdr, p)) {
xfprintf(pic, file, " ");
write_pair_help(pic, cdr, file, p);
pic_fprintf(pic, port, " ");
write_pair_help(pic, cdr, port, p);
}
else {
xfprintf(pic, file, " . ");
write_core(pic, cdr, file, p);
pic_fprintf(pic, port, " . ");
write_core(pic, cdr, port, p);
}
}
#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0)
static void
write_pair(pic_state *pic, pic_value pair, xFILE *file, struct writer_control *p)
write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
{
pic_value tag;
if (pic_pair_p(pic, pic_cdr(pic, pair)) && pic_nil_p(pic, pic_cddr(pic, pair)) && pic_sym_p(pic, pic_car(pic, pair))) {
tag = pic_car(pic, pair);
if (EQ(tag, "quote")) {
xfprintf(pic, file, "'");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, "'");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "unquote")) {
xfprintf(pic, file, ",");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, ",");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "unquote-splicing")) {
xfprintf(pic, file, ",@");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, ",@");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "quasiquote")) {
xfprintf(pic, file, "`");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, "`");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-quote")) {
xfprintf(pic, file, "#'");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, "#'");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-unquote")) {
xfprintf(pic, file, "#,");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, "#,");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-unquote-splicing")) {
xfprintf(pic, file, "#,@");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, "#,@");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-quasiquote")) {
xfprintf(pic, file, "#`");
write_core(pic, pic_cadr(pic, pair), file, p);
pic_fprintf(pic, port, "#`");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
}
xfprintf(pic, file, "(");
write_pair_help(pic, pair, file, p);
xfprintf(pic, file, ")");
pic_fprintf(pic, port, "(");
write_pair_help(pic, pair, port, p);
pic_fprintf(pic, port, ")");
}
static void
write_vec(pic_state *pic, pic_value vec, xFILE *file, struct writer_control *p)
write_vec(pic_state *pic, pic_value vec, pic_value port, struct writer_control *p)
{
int i, len = pic_vec_len(pic, vec);
xfprintf(pic, file, "#(");
pic_fprintf(pic, port, "#(");
for (i = 0; i < len; ++i) {
write_core(pic, pic_vec_ref(pic, vec, i), file, p);
write_core(pic, pic_vec_ref(pic, vec, i), port, p);
if (i + 1 < len) {
xfprintf(pic, file, " ");
pic_fprintf(pic, port, " ");
}
}
xfprintf(pic, file, ")");
pic_fprintf(pic, port, ")");
}
static void
write_dict(pic_state *pic, pic_value dict, xFILE *file, struct writer_control *p)
write_dict(pic_state *pic, pic_value dict, pic_value port, struct writer_control *p)
{
pic_value key, val;
int it = 0;
xfprintf(pic, file, "#.(dictionary");
pic_fprintf(pic, port, "#.(dictionary");
while (pic_dict_next(pic, dict, &it, &key, &val)) {
xfprintf(pic, file, " '%s ", pic_sym(pic, key));
write_core(pic, val, file, p);
pic_fprintf(pic, port, " '%s ", pic_sym(pic, key));
write_core(pic, val, port, p);
}
xfprintf(pic, file, ")");
pic_fprintf(pic, port, ")");
}
static void
write_core(pic_state *pic, pic_value obj, xFILE *file, struct writer_control *p)
write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control *p)
{
pic_value labels = p->labels;
int i;
@ -290,62 +417,62 @@ write_core(pic_state *pic, pic_value obj, xFILE *file, struct writer_control *p)
/* shared objects */
if (is_shared_object(pic, obj, p)) {
if (pic_weak_has(pic, labels, obj)) {
xfprintf(pic, file, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj)));
pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj)));
return;
}
i = p->cnt++;
xfprintf(pic, file, "#%d=", i);
pic_fprintf(pic, port, "#%d=", i);
pic_weak_set(pic, labels, obj, pic_int_value(pic, i));
}
switch (pic_type(pic, obj)) {
case PIC_TYPE_UNDEF:
xfprintf(pic, file, "#undefined");
pic_fprintf(pic, port, "#undefined");
break;
case PIC_TYPE_NIL:
xfprintf(pic, file, "()");
pic_fprintf(pic, port, "()");
break;
case PIC_TYPE_TRUE:
xfprintf(pic, file, "#t");
pic_fprintf(pic, port, "#t");
break;
case PIC_TYPE_FALSE:
xfprintf(pic, file, "#f");
pic_fprintf(pic, port, "#f");
break;
case PIC_TYPE_ID:
xfprintf(pic, file, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj)));
pic_fprintf(pic, port, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj)));
break;
case PIC_TYPE_EOF:
xfprintf(pic, file, "#.(eof-object)");
pic_fprintf(pic, port, "#.(eof-object)");
break;
case PIC_TYPE_INT:
xfprintf(pic, file, "%d", pic_int(pic, obj));
pic_fprintf(pic, port, "%d", pic_int(pic, obj));
break;
case PIC_TYPE_SYMBOL:
xfprintf(pic, file, "%s", pic_sym(pic, obj));
pic_fprintf(pic, port, "%s", pic_sym(pic, obj));
break;
case PIC_TYPE_FLOAT:
write_float(pic, obj, file);
write_float(pic, obj, port);
break;
case PIC_TYPE_BLOB:
write_blob(pic, obj, file);
write_blob(pic, obj, port);
break;
case PIC_TYPE_CHAR:
write_char(pic, obj, file, p);
write_char(pic, obj, port, p);
break;
case PIC_TYPE_STRING:
write_str(pic, obj, file, p);
write_str(pic, obj, port, p);
break;
case PIC_TYPE_PAIR:
write_pair(pic, obj, file, p);
write_pair(pic, obj, port, p);
break;
case PIC_TYPE_VECTOR:
write_vec(pic, obj, file, p);
write_vec(pic, obj, port, p);
break;
case PIC_TYPE_DICT:
write_dict(pic, obj, file, p);
write_dict(pic, obj, port, p);
break;
default:
xfprintf(pic, file, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj));
pic_fprintf(pic, port, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj));
break;
}
@ -357,7 +484,7 @@ write_core(pic_state *pic, pic_value obj, xFILE *file, struct writer_control *p)
}
static void
write_value(pic_state *pic, pic_value obj, xFILE *file, int mode, int op)
write_value(pic_state *pic, pic_value obj, pic_value port, int mode, int op)
{
struct writer_control p;
@ -365,94 +492,7 @@ write_value(pic_state *pic, pic_value obj, xFILE *file, int mode, int op)
traverse(pic, obj, &p);
write_core(pic, obj, file, &p);
}
void
pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap)
{
xFILE *file = pic_fileno(pic, port);
char c;
while ((c = *fmt++) != '\0') {
switch (c) {
default:
xfputc(pic, c, file);
break;
case '%':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(pic, c, file);
break;
case '%':
xfputc(pic, '%', file);
break;
case 'c':
xfprintf(pic, file, "%c", va_arg(ap, int));
break;
case 's':
xfprintf(pic, file, "%s", va_arg(ap, const char *));
break;
case 'd':
xfprintf(pic, file, "%d", va_arg(ap, int));
break;
case 'p':
xfprintf(pic, file, "%p", va_arg(ap, void *));
break;
case 'f':
xfprintf(pic, file, "%f", va_arg(ap, double));
break;
}
break;
case '~':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(pic, c, file);
break;
case '~':
xfputc(pic, '~', file);
break;
case '%':
xfputc(pic, '\n', file);
break;
case 'a':
write_value(pic, va_arg(ap, pic_value), file, DISPLAY_MODE, OP_WRITE);
break;
case 's':
write_value(pic, va_arg(ap, pic_value), file, WRITE_MODE, OP_WRITE);
break;
}
break;
}
}
exit:
xfflush(pic, file);
}
void
pic_fprintf(pic_state *pic, pic_value port, const char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
pic_vfprintf(pic, port, fmt, ap);
va_end(ap);
}
void
pic_printf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
pic_vfprintf(pic, pic_stdout(pic), fmt, ap);
va_end(ap);
write_core(pic, obj, port, &p);
}
static pic_value
@ -461,7 +501,7 @@ pic_write_write(pic_state *pic)
pic_value v, port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_value(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE);
write_value(pic, v, port, WRITE_MODE, OP_WRITE);
return pic_undef_value(pic);
}
@ -471,7 +511,7 @@ pic_write_write_simple(pic_state *pic)
pic_value v, port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_value(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SIMPLE);
write_value(pic, v, port, WRITE_MODE, OP_WRITE_SIMPLE);
return pic_undef_value(pic);
}
@ -481,7 +521,7 @@ pic_write_write_shared(pic_state *pic)
pic_value v, port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_value(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SHARED);
write_value(pic, v, port, WRITE_MODE, OP_WRITE_SHARED);
return pic_undef_value(pic);
}
@ -491,7 +531,7 @@ pic_write_display(pic_state *pic)
pic_value v, port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_value(pic, v, pic_fileno(pic, port), DISPLAY_MODE, OP_WRITE);
write_value(pic, v, port, DISPLAY_MODE, OP_WRITE);
return pic_undef_value(pic);
}

2
src/main.c
View File

@ -45,7 +45,7 @@ main(int argc, char *argv[], char **envp)
status = 0;
}
pic_catch(e) {
pic_print_error(pic, xstderr, e);
pic_print_error(pic, pic_stderr(pic), e);
status = 1;
}