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

Merge branch 'native-xfile-support'

This commit is contained in:
Yuichi Nishiwaki 2015-06-19 04:01:18 +09:00
parent d1aa42cd7a cf037f27db
commit fa3073892f
20 changed files with 492 additions and 536 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -20,7 +20,7 @@ generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
struct pic_port *port; struct pic_port *port;
xFILE *file; xFILE *file;
file = xfopen(fname, mode); file = xfopen(pic, fname, mode);
if (! file) { if (! file) {
file_error(pic, "could not open file"); file_error(pic, "could not open file");
} }

2
contrib/05.r7rs/src/load.c
View File

@ -10,7 +10,7 @@ pic_load(pic_state *pic, const char *filename)
struct pic_port *port; struct pic_port *port;
xFILE *file; xFILE *file;
file = xfopen(filename, "r"); file = xfopen(pic, filename, "r");
if (file == NULL) { if (file == NULL) {
pic_errorf(pic, "could not open file: %s", filename); pic_errorf(pic, "could not open file: %s", filename);
} }

10
extlib/benz/debug.c
View File

@ -38,7 +38,7 @@ pic_print_backtrace(pic_state *pic, xFILE *file)
assert(! pic_invalid_p(pic->err)); assert(! pic_invalid_p(pic->err));
if (! pic_error_p(pic->err)) { if (! pic_error_p(pic->err)) {
xfprintf(file, "raise: "); xfprintf(pic, file, "raise: ");
pic_fwrite(pic, pic->err, file); pic_fwrite(pic, pic->err, file);
} else { } else {
struct pic_error *e; struct pic_error *e;
@ -46,14 +46,14 @@ pic_print_backtrace(pic_state *pic, xFILE *file)
e = pic_error_ptr(pic->err); e = pic_error_ptr(pic->err);
if (e->type != pic_intern_cstr(pic, "")) { if (e->type != pic_intern_cstr(pic, "")) {
pic_fwrite(pic, pic_obj_value(e->type), file); pic_fwrite(pic, pic_obj_value(e->type), file);
xfprintf(file, " "); xfprintf(pic, file, " ");
} }
xfprintf(file, "error: "); xfprintf(pic, file, "error: ");
pic_fwrite(pic, pic_obj_value(e->msg), file); pic_fwrite(pic, pic_obj_value(e->msg), file);
xfprintf(file, "\n"); xfprintf(pic, file, "\n");
/* TODO: print error irritants */ /* TODO: print error irritants */
xfputs(pic_str_cstr(pic, e->stack), file); xfputs(pic, pic_str_cstr(pic, e->stack), file);
} }
} }

2
extlib/benz/error.c
View File

@ -27,7 +27,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
err_line = pic_xvformat(pic, fmt, ap); err_line = pic_xvformat(pic, fmt, ap);
va_end(ap); va_end(ap);
xfprintf(pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line)))); xfprintf(pic, pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line))));
} }
void void

150
extlib/benz/xfile.c → extlib/benz/file.c
View File

@ -1,6 +1,7 @@
#include "picrin.h" #include "picrin.h"
static int file_read(void *cookie, char *ptr, int size) { static int
file_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size) {
FILE *file = cookie; FILE *file = cookie;
int r; int r;
@ -16,7 +17,8 @@ static int file_read(void *cookie, char *ptr, int size) {
return r; return r;
} }
static int file_write(void *cookie, const char *ptr, int size) { static int
file_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size) {
FILE *file = cookie; FILE *file = cookie;
int r; int r;
@ -28,7 +30,8 @@ static int file_write(void *cookie, const char *ptr, int size) {
return r; return r;
} }
static long file_seek(void *cookie, long pos, int whence) { static long
file_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence) {
switch (whence) { switch (whence) {
case XSEEK_CUR: case XSEEK_CUR:
whence = SEEK_CUR; whence = SEEK_CUR;
@ -43,11 +46,12 @@ static long file_seek(void *cookie, long pos, int whence) {
return fseek(cookie, pos, whence); return fseek(cookie, pos, whence);
} }
static int file_close(void *cookie) { static int
file_close(pic_state PIC_UNUSED(*pic), void *cookie) {
return fclose(cookie); return fclose(cookie);
} }
xFILE *xfopen(const char *name, const char *mode) { xFILE *xfopen(pic_state *pic, const char *name, const char *mode) {
FILE *fp; FILE *fp;
if ((fp = fopen(name, mode)) == NULL) { if ((fp = fopen(name, mode)) == NULL) {
@ -56,28 +60,28 @@ xFILE *xfopen(const char *name, const char *mode) {
switch (*mode) { switch (*mode) {
case 'r': case 'r':
return xfunopen(fp, file_read, NULL, file_seek, file_close); return xfunopen(pic, fp, file_read, NULL, file_seek, file_close);
default: default:
return xfunopen(fp, NULL, file_write, file_seek, file_close); return xfunopen(pic, fp, NULL, file_write, file_seek, file_close);
} }
} }
#define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close } #define FILE_VTABLE { 0, file_read, file_write, file_seek, file_close }
xFILE x_iob[XOPEN_MAX] = { const xFILE x_iob[XOPEN_MAX] = {
{ { 0 }, 0, NULL, NULL, FILE_VTABLE, X_READ }, { { 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_LNBUF },
{ { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF } { { 0 }, 0, NULL, NULL, FILE_VTABLE, X_WRITE | X_UNBUF }
}; };
xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*close)(void *)) { 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; xFILE *fp;
for (fp = x_iob; fp < x_iob + XOPEN_MAX; fp++) for (fp = pic->files; fp < pic->files + XOPEN_MAX; fp++)
if ((fp->flag & (X_READ | X_WRITE)) == 0) if ((fp->flag & (X_READ | X_WRITE)) == 0)
break; /* found free slot */ break; /* found free slot */
if (fp >= x_iob + XOPEN_MAX) /* no free slots */ if (fp >= pic->files + XOPEN_MAX) /* no free slots */
return NULL; return NULL;
fp->cnt = 0; fp->cnt = 0;
@ -93,18 +97,15 @@ xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(voi
return fp; return fp;
} }
int xfclose(xFILE *fp) { int xfclose(pic_state *pic, xFILE *fp) {
extern void free(void *); /* FIXME */ xfflush(pic, fp);
xfflush(fp);
fp->flag = 0; fp->flag = 0;
if (fp->base != fp->buf) if (fp->base != fp->buf)
free(fp->base); pic_free(pic, fp->base);
return fp->vtable.close(fp->vtable.cookie); return fp->vtable.close(pic, fp->vtable.cookie);
} }
int x_fillbuf(xFILE *fp) { int x_fillbuf(pic_state *pic, xFILE *fp) {
extern void *malloc(size_t); /* FIXME */
int bufsize; int bufsize;
if ((fp->flag & (X_READ|X_EOF|X_ERR)) != X_READ) if ((fp->flag & (X_READ|X_EOF|X_ERR)) != X_READ)
@ -112,7 +113,7 @@ int x_fillbuf(xFILE *fp) {
if (fp->base == NULL) { if (fp->base == NULL) {
if ((fp->flag & X_UNBUF) == 0) { if ((fp->flag & X_UNBUF) == 0) {
/* no buffer yet */ /* no buffer yet */
if ((fp->base = malloc(XBUFSIZ)) == NULL) { if ((fp->base = pic_malloc(pic, XBUFSIZ)) == NULL) {
/* can't get buffer, try unbuffered */ /* can't get buffer, try unbuffered */
fp->flag |= X_UNBUF; fp->flag |= X_UNBUF;
} }
@ -124,7 +125,7 @@ int x_fillbuf(xFILE *fp) {
bufsize = (fp->flag & X_UNBUF) ? sizeof(fp->buf) : XBUFSIZ; bufsize = (fp->flag & X_UNBUF) ? sizeof(fp->buf) : XBUFSIZ;
fp->ptr = fp->base; fp->ptr = fp->base;
fp->cnt = fp->vtable.read(fp->vtable.cookie, fp->ptr, bufsize); fp->cnt = fp->vtable.read(pic, fp->vtable.cookie, fp->ptr, bufsize);
if (--fp->cnt < 0) { if (--fp->cnt < 0) {
if (fp->cnt == -1) if (fp->cnt == -1)
@ -138,8 +139,7 @@ int x_fillbuf(xFILE *fp) {
return (unsigned char) *fp->ptr++; return (unsigned char) *fp->ptr++;
} }
int x_flushbuf(int x, xFILE *fp) { int x_flushbuf(pic_state *pic, int x, xFILE *fp) {
extern void *malloc(size_t); /* FIXME */
int num_written=0, bufsize=0; int num_written=0, bufsize=0;
char c = x; char c = x;
@ -147,7 +147,7 @@ int x_flushbuf(int x, xFILE *fp) {
return EOF; return EOF;
if (fp->base == NULL && ((fp->flag & X_UNBUF) == 0)) { if (fp->base == NULL && ((fp->flag & X_UNBUF) == 0)) {
/* no buffer yet */ /* no buffer yet */
if ((fp->base = malloc(XBUFSIZ)) == NULL) { if ((fp->base = pic_malloc(pic, XBUFSIZ)) == NULL) {
/* couldn't allocate a buffer, so try unbuffered */ /* couldn't allocate a buffer, so try unbuffered */
fp->flag |= X_UNBUF; fp->flag |= X_UNBUF;
} else { } else {
@ -161,7 +161,7 @@ int x_flushbuf(int x, xFILE *fp) {
fp->cnt = 0; fp->cnt = 0;
if (x == EOF) if (x == EOF)
return EOF; return EOF;
num_written = fp->vtable.write(fp->vtable.cookie, (const char *) &c, 1); num_written = fp->vtable.write(pic, fp->vtable.cookie, (const char *) &c, 1);
bufsize = 1; bufsize = 1;
} else { } else {
/* buffered write */ /* buffered write */
@ -172,7 +172,7 @@ int x_flushbuf(int x, xFILE *fp) {
bufsize = (int)(fp->ptr - fp->base); bufsize = (int)(fp->ptr - fp->base);
while(bufsize - num_written > 0) { while(bufsize - num_written > 0) {
int t; int t;
t = fp->vtable.write(fp->vtable.cookie, fp->base + num_written, bufsize - num_written); t = fp->vtable.write(pic, fp->vtable.cookie, fp->base + num_written, bufsize - num_written);
if (t < 0) if (t < 0)
break; break;
num_written += t; num_written += t;
@ -190,7 +190,7 @@ int x_flushbuf(int x, xFILE *fp) {
} }
} }
int xfflush(xFILE *f) { int xfflush(pic_state *pic, xFILE *f) {
int retval; int retval;
int i; int i;
@ -198,48 +198,48 @@ int xfflush(xFILE *f) {
if (f == NULL) { if (f == NULL) {
/* flush all output streams */ /* flush all output streams */
for (i = 0; i < XOPEN_MAX; i++) { for (i = 0; i < XOPEN_MAX; i++) {
if ((x_iob[i].flag & X_WRITE) && (xfflush(&x_iob[i]) == -1)) if ((pic->files[i].flag & X_WRITE) && (xfflush(pic, &pic->files[i]) == -1))
retval = -1; retval = -1;
} }
} else { } else {
if ((f->flag & X_WRITE) == 0) if ((f->flag & X_WRITE) == 0)
return -1; return -1;
x_flushbuf(EOF, f); x_flushbuf(pic, EOF, f);
if (f->flag & X_ERR) if (f->flag & X_ERR)
retval = -1; retval = -1;
} }
return retval; return retval;
} }
int xfputc(int x, xFILE *fp) { int xfputc(pic_state *pic, int x, xFILE *fp) {
return xputc(x, fp); return xputc(pic, x, fp);
} }
int xfgetc(xFILE *fp) { int xfgetc(pic_state *pic, xFILE *fp) {
return xgetc(fp); return xgetc(pic, fp);
} }
int xfputs(const char *s, xFILE *stream) { int xfputs(pic_state *pic, const char *s, xFILE *stream) {
const char *ptr = s; const char *ptr = s;
while(*ptr != '\0') { while(*ptr != '\0') {
if (xputc(*ptr, stream) == EOF) if (xputc(pic, *ptr, stream) == EOF)
return EOF; return EOF;
++ptr; ++ptr;
} }
return (int)(ptr - s); return (int)(ptr - s);
} }
char *xfgets(char *s, int size, xFILE *stream) { char *xfgets(pic_state *pic, char *s, int size, xFILE *stream) {
int c; int c;
char *buf; char *buf;
xfflush(NULL); xfflush(pic, NULL);
if (size == 0) { if (size == 0) {
return NULL; return NULL;
} }
buf = s; buf = s;
while (--size > 0 && (c = xgetc(stream)) != EOF) { while (--size > 0 && (c = xgetc(pic, stream)) != EOF) {
if ((*buf++ = c) == '\n') if ((*buf++ = c) == '\n')
break; break;
} }
@ -248,28 +248,28 @@ char *xfgets(char *s, int size, xFILE *stream) {
return (c == EOF && buf == s) ? NULL : s; return (c == EOF && buf == s) ? NULL : s;
} }
int xputs(const char *s) { int xputs(pic_state *pic, const char *s) {
int i = 1; int i = 1;
while(*s != '\0') { while(*s != '\0') {
if (xputchar(*s++) == EOF) if (xputchar(pic, *s++) == EOF)
return EOF; return EOF;
i++; i++;
} }
if (xputchar('\n') == EOF) { if (xputchar(pic, '\n') == EOF) {
return EOF; return EOF;
} }
return i; return i;
} }
char *xgets(char *s) { char *xgets(pic_state *pic, char *s) {
int c; int c;
char *buf; char *buf;
xfflush(NULL); xfflush(pic, NULL);
buf = s; buf = s;
while ((c = xgetchar()) != EOF && c != '\n') { while ((c = xgetchar(pic)) != EOF && c != '\n') {
*buf++ = c; *buf++ = c;
} }
*buf = '\0'; *buf = '\0';
@ -287,7 +287,7 @@ int xungetc(int c, xFILE *fp) {
return *--fp->ptr = uc; return *--fp->ptr = uc;
} }
size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) { size_t xfread(pic_state *pic, void *ptr, size_t size, size_t count, xFILE *fp) {
char *bptr = ptr; char *bptr = ptr;
long nbytes; long nbytes;
int c; int c;
@ -298,7 +298,7 @@ size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) {
fp->ptr += fp->cnt; fp->ptr += fp->cnt;
bptr += fp->cnt; bptr += fp->cnt;
nbytes -= fp->cnt; nbytes -= fp->cnt;
if ((c = x_fillbuf(fp)) == EOF) { if ((c = x_fillbuf(pic, fp)) == EOF) {
return (size * count - nbytes) / size; return (size * count - nbytes) / size;
} else { } else {
xungetc(c, fp); xungetc(c, fp);
@ -310,7 +310,7 @@ size_t xfread(void *ptr, size_t size, size_t count, xFILE *fp) {
return count; return count;
} }
size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) { size_t xfwrite(pic_state *pic, const void *ptr, size_t size, size_t count, xFILE *fp) {
const char *bptr = ptr; const char *bptr = ptr;
long nbytes; long nbytes;
@ -320,7 +320,7 @@ size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) {
fp->ptr += fp->cnt; fp->ptr += fp->cnt;
bptr += fp->cnt; bptr += fp->cnt;
nbytes -= fp->cnt; nbytes -= fp->cnt;
if (x_flushbuf(EOF, fp) == EOF) { if (x_flushbuf(pic, EOF, fp) == EOF) {
return (size * count - nbytes) / size; return (size * count - nbytes) / size;
} }
} }
@ -330,50 +330,50 @@ size_t xfwrite(const void *ptr, size_t size, size_t count, xFILE *fp) {
return count; return count;
} }
long xfseek(xFILE *fp, long offset, int whence) { long xfseek(pic_state *pic, xFILE *fp, long offset, int whence) {
long s; long s;
xfflush(fp); xfflush(pic, fp);
fp->ptr = fp->base; fp->ptr = fp->base;
fp->cnt = 0; fp->cnt = 0;
if ((s = fp->vtable.seek(fp->vtable.cookie, offset, whence)) != 0) if ((s = fp->vtable.seek(pic, fp->vtable.cookie, offset, whence)) != 0)
return s; return s;
fp->flag &= ~X_EOF; fp->flag &= ~X_EOF;
return 0; return 0;
} }
long xftell(xFILE *fp) { long xftell(pic_state *pic, xFILE *fp) {
return xfseek(fp, 0, XSEEK_CUR); return xfseek(pic, fp, 0, XSEEK_CUR);
} }
void xrewind(xFILE *fp) { void xrewind(pic_state *pic, xFILE *fp) {
xfseek(fp, 0, XSEEK_SET); xfseek(pic, fp, 0, XSEEK_SET);
xclearerr(fp); xclearerr(fp);
} }
int xprintf(const char *fmt, ...) { int xprintf(pic_state *pic, const char *fmt, ...) {
va_list ap; va_list ap;
int n; int n;
va_start(ap, fmt); va_start(ap, fmt);
n = xvfprintf(xstdout, fmt, ap); n = xvfprintf(pic, xstdout, fmt, ap);
va_end(ap); va_end(ap);
return n; return n;
} }
int xfprintf(xFILE *stream, const char *fmt, ...) { int xfprintf(pic_state *pic, xFILE *stream, const char *fmt, ...) {
va_list ap; va_list ap;
int n; int n;
va_start(ap, fmt); va_start(ap, fmt);
n = xvfprintf(stream, fmt, ap); n = xvfprintf(pic, stream, fmt, ap);
va_end(ap); va_end(ap);
return n; return n;
} }
static int print_int(xFILE *stream, long x, int base) { static int print_int(pic_state *pic, xFILE *stream, long x, int base) {
static const char digits[] = "0123456789abcdef"; static const char digits[] = "0123456789abcdef";
char buf[20]; char buf[20];
int i, c, neg; int i, c, neg;
@ -395,12 +395,12 @@ static int print_int(xFILE *stream, long x, int base) {
c = i; c = i;
while (i-- > 0) { while (i-- > 0) {
xputc(buf[i], stream); xputc(pic, buf[i], stream);
} }
return c; return c;
} }
int xvfprintf(xFILE *stream, const char *fmt, va_list ap) { int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) {
const char *p; const char *p;
char *sval; char *sval;
int ival; int ival;
@ -412,7 +412,7 @@ int xvfprintf(xFILE *stream, const char *fmt, va_list ap) {
for (p = fmt; *p; p++) { for (p = fmt; *p; p++) {
if (*p != '%') { if (*p != '%') {
xputc(*p, stream); xputc(pic, *p, stream);
cnt++; cnt++;
continue; continue;
} }
@ -420,42 +420,42 @@ int xvfprintf(xFILE *stream, const char *fmt, va_list ap) {
case 'd': case 'd':
case 'i': case 'i':
ival = va_arg(ap, int); ival = va_arg(ap, int);
cnt += print_int(stream, ival, 10); cnt += print_int(pic, stream, ival, 10);
break; break;
#if PIC_ENABLE_FLOAT #if PIC_ENABLE_FLOAT
case 'f': case 'f':
dval = va_arg(ap, double); dval = va_arg(ap, double);
cnt += print_int(stream, dval, 10); cnt += print_int(pic, stream, dval, 10);
xputc('.', stream); xputc(pic, '.', stream);
cnt++; cnt++;
if ((ival = fabs((dval - floor(dval)) * 1e4) + 0.5) == 0) { if ((ival = fabs((dval - floor(dval)) * 1e4) + 0.5) == 0) {
cnt += xfputs("0000", stream); cnt += xfputs(pic, "0000", stream);
} else { } else {
int i; int i;
for (i = 0; i < 3 - (int)log10(ival); ++i) { for (i = 0; i < 3 - (int)log10(ival); ++i) {
xputc('0', stream); xputc(pic, '0', stream);
cnt++; cnt++;
} }
cnt += print_int(stream, ival, 10); cnt += print_int(pic, stream, ival, 10);
} }
break; break;
#endif #endif
case 's': case 's':
sval = va_arg(ap, char*); sval = va_arg(ap, char*);
cnt += xfputs(sval, stream); cnt += xfputs(pic, sval, stream);
break; break;
case 'p': case 'p':
vp = va_arg(ap, void*); vp = va_arg(ap, void*);
cnt += xfputs("0x", stream); cnt += xfputs(pic, "0x", stream);
cnt += print_int(stream, (long)vp, 16); cnt += print_int(pic, stream, (long)vp, 16);
break; break;
case '%': case '%':
xputc(*(p-1), stream); xputc(pic, *(p-1), stream);
cnt++; cnt++;
break; break;
default: default:
xputc('%', stream); xputc(pic, '%', stream);
xputc(*(p-1), stream); xputc(pic, *(p-1), stream);
cnt += 2; cnt += 2;
break; break;
} }

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

@ -33,20 +33,19 @@ extern "C" {
#include <stdarg.h> #include <stdarg.h>
#include "picrin/config.h" #include "picrin/config.h"
#include "picrin/util.h"
#include "picrin/compat.h" #include "picrin/compat.h"
#if PIC_ENABLE_FLOAT
# include <math.h>
#endif
#include "picrin/xvect.h" #include "picrin/xvect.h"
#include "picrin/xhash.h" #include "picrin/xhash.h"
#include "picrin/xfile.h"
#include "picrin/value.h" #include "picrin/value.h"
typedef struct pic_code pic_code; typedef struct pic_state pic_state;
#include "picrin/irep.h"
#include "picrin/file.h"
#include "picrin/read.h"
#include "picrin/gc.h"
typedef struct pic_jmpbuf { typedef struct pic_jmpbuf {
PIC_JMPBUF buf; PIC_JMPBUF buf;
@ -72,7 +71,7 @@ typedef struct {
typedef void *(*pic_allocf)(void *, size_t); typedef void *(*pic_allocf)(void *, size_t);
typedef struct { struct pic_state {
int argc; int argc;
char **argv, **envp; char **argv, **envp;
@ -135,7 +134,9 @@ typedef struct {
pic_value libs; pic_value libs;
struct pic_reg *attrs; struct pic_reg *attrs;
struct pic_reader *reader; pic_reader reader;
xFILE files[XOPEN_MAX];
pic_code iseq[2]; /* for pic_apply_trampoline */
bool gc_enable; bool gc_enable;
struct pic_heap *heap; struct pic_heap *heap;
@ -145,9 +146,8 @@ typedef struct {
pic_value err; pic_value err;
pic_code *iseq; /* for pic_apply_trampoline */
char *native_stack_start; char *native_stack_start;
} pic_state; };
typedef pic_value (*pic_func_t)(pic_state *); typedef pic_value (*pic_func_t)(pic_state *);
@ -254,6 +254,7 @@ struct pic_port *pic_stderr(pic_state *);
pic_value pic_write(pic_state *, pic_value); /* returns given obj */ pic_value pic_write(pic_state *, pic_value); /* returns given obj */
pic_value pic_fwrite(pic_state *, pic_value, xFILE *); pic_value pic_fwrite(pic_state *, pic_value, xFILE *);
void pic_printf(pic_state *, const char *, ...); void pic_printf(pic_state *, const char *, ...);
void pic_fprintf(pic_state *, struct pic_port *, const char *, ...);
pic_value pic_display(pic_state *, pic_value); pic_value pic_display(pic_state *, pic_value);
pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
@ -267,18 +268,14 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
#include "picrin/data.h" #include "picrin/data.h"
#include "picrin/dict.h" #include "picrin/dict.h"
#include "picrin/error.h" #include "picrin/error.h"
#include "picrin/gc.h"
#include "picrin/irep.h"
#include "picrin/lib.h" #include "picrin/lib.h"
#include "picrin/macro.h" #include "picrin/macro.h"
#include "picrin/pair.h" #include "picrin/pair.h"
#include "picrin/port.h" #include "picrin/port.h"
#include "picrin/proc.h" #include "picrin/proc.h"
#include "picrin/read.h"
#include "picrin/record.h" #include "picrin/record.h"
#include "picrin/string.h" #include "picrin/string.h"
#include "picrin/symbol.h" #include "picrin/symbol.h"
#include "picrin/read.h"
#include "picrin/vector.h" #include "picrin/vector.h"
#include "picrin/reg.h" #include "picrin/reg.h"

75
extlib/benz/include/picrin/compat.h
View File

@ -9,6 +9,77 @@
extern "C" { extern "C" {
#endif #endif
#if __STDC_VERSION__ >= 199901L
# include <stdbool.h>
#else
# define bool char
# define true 1
# define false 0
#endif
#if __STDC_VERSION__ >= 199901L
# include <stddef.h>
#elif ! defined(offsetof)
# define offsetof(s,m) ((size_t)&(((s *)NULL)->m))
#endif
#if __STDC_VERSION__ >= 201112L
# include <stdnoreturn.h>
# define PIC_NORETURN noreturn
#elif __GNUC__ || __clang__
# define PIC_NORETURN __attribute__((noreturn))
#else
# define PIC_NORETURN
#endif
#if __STDC_VERSION__ >= 199901L
# define PIC_INLINE static inline
#elif __GNUC__ || __clang__
# define PIC_INLINE static __inline__
#else
# define PIC_INLINE static
#endif
#define PIC_FALLTHROUGH ((void)0)
#if __GNUC__ || __clang__
# define PIC_UNUSED(v) __attribute__((unused)) v
#else
# define PIC_UNUSED(v) v
#endif
#define PIC_GENSYM2_(x,y) PIC_G##x##_##y##_
#define PIC_GENSYM1_(x,y) PIC_GENSYM2_(x,y)
#if defined(__COUNTER__)
# define PIC_GENSYM(x) PIC_GENSYM1_(__COUNTER__,x)
#else
# define PIC_GENSYM(x) PIC_GENSYM1_(__LINE__,x)
#endif
#if __GNUC__
# define GCC_VERSION (__GNUC__ * 10000 \
+ __GNUC_MINOR__ * 100 \
+ __GNUC_PATCHLEVEL__)
#endif
#if GCC_VERSION >= 40500 || __clang__
# define PIC_UNREACHABLE() (__builtin_unreachable())
#else
# define PIC_UNREACHABLE() (assert(false))
#endif
#if __GNUC__
# undef GCC_VERSION
#endif
#define PIC_SWAP(type,a,b) \
PIC_SWAP_HELPER_(type, PIC_GENSYM(tmp), a, b)
#define PIC_SWAP_HELPER_(type,tmp,a,b) \
do { \
type tmp = (a); \
(a) = (b); \
(b) = tmp; \
} while (0)
#if PIC_ENABLE_LIBC #if PIC_ENABLE_LIBC
#include <string.h> #include <string.h>
@ -134,6 +205,10 @@ strcpy(char *dst, const char *src)
#endif #endif
#if PIC_ENABLE_FLOAT
# include <math.h>
#endif
#if defined(__cplusplus) #if defined(__cplusplus)
} }
#endif #endif

107
extlib/benz/include/picrin/file.h Normal file
View File

@ -0,0 +1,107 @@
#ifndef PICRIN_FILE_H
#define PICRIN_FILE_H
#if defined(__cplusplus)
extern "C" {
#endif
#include <stdio.h>
#ifndef EOF
# define EOF (-1)
#endif
#define XBUFSIZ 1024
#define XOPEN_MAX 1024
typedef struct {
/* buffer */
char buf[1]; /* fallback buffer */
long cnt; /* characters left */
char *ptr; /* next character position */
char *base; /* location of the buffer */
/* operators */
struct {
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 *);
} vtable;
int flag; /* mode of the file access */
} xFILE;
#define xstdin (&pic->files[0])
#define xstdout (&pic->files[1])
#define xstderr (&pic->files[2])
extern const xFILE x_iob[XOPEN_MAX];
enum _flags {
X_READ = 01,
X_WRITE = 02,
X_UNBUF = 04,
X_EOF = 010,
X_ERR = 020,
X_LNBUF = 040
};
#define xclearerr(p) ((p)->flag &= ~(X_EOF | X_ERR))
#define xfeof(p) (((p)->flag & X_EOF) != 0)
#define xferror(p) (((p)->flag & X_ERR) != 0)
#define xfileno(p) ((p)->fd)
#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)))
#define xgetchar(pic) xgetc((pic), xstdin)
#define xputchar(pic, x) xputc((pic), (x), xstdout)
/* 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 */
int x_fillbuf(pic_state *, xFILE *);
int x_flushbuf(pic_state *, int, xFILE *);
int xfflush(pic_state *, xFILE *);
/* direct IO */
size_t xfread(pic_state *, void *, size_t, size_t, xFILE *);
size_t xfwrite(pic_state *, const void *, size_t, size_t, xFILE *);
enum {
XSEEK_CUR,
XSEEK_END,
XSEEK_SET
};
/* indicator positioning */
long xfseek(pic_state *, xFILE *, long, int);
long xftell(pic_state *, xFILE *);
void xrewind(pic_state *, xFILE *);
/* character IO */
int xfputc(pic_state *, int, xFILE *);
int xfgetc(pic_state *, xFILE *);
int xfputs(pic_state *, const char *, xFILE *);
char *xfgets(pic_state *, char *, int, xFILE *);
int xputs(pic_state *, const char *);
int xungetc(int, xFILE *);
/* formatted I/O */
int xprintf(pic_state *, const char *, ...);
int xfprintf(pic_state *, xFILE *, const char *, ...);
int xvfprintf(pic_state *, xFILE *, const char *, va_list);
#if defined(__cplusplus)
}
#endif
#endif

4
extlib/benz/include/picrin/irep.h
View File

@ -49,7 +49,7 @@ enum pic_opcode {
OP_STOP OP_STOP
}; };
struct pic_code { typedef struct {
enum pic_opcode insn; enum pic_opcode insn;
union { union {
int i; int i;
@ -59,7 +59,7 @@ struct pic_code {
int idx; int idx;
} r; } r;
} u; } u;
}; } pic_code;
#define PIC_INIT_CODE_I(code, op, ival) do { \ #define PIC_INIT_CODE_I(code, op, ival) do { \
code.insn = op; \ code.insn = op; \

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

@ -11,7 +11,7 @@ extern "C" {
typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c); typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c);
struct pic_reader { typedef struct {
enum pic_typecase { enum pic_typecase {
PIC_CASE_DEFAULT, PIC_CASE_DEFAULT,
PIC_CASE_FOLD PIC_CASE_FOLD
@ -19,10 +19,10 @@ struct pic_reader {
xhash labels; xhash labels;
pic_reader_t table[256]; pic_reader_t table[256];
pic_reader_t dispatch[256]; pic_reader_t dispatch[256];
}; } pic_reader;
struct pic_reader *pic_reader_open(pic_state *); void pic_reader_init(pic_state *);
void pic_reader_close(pic_state *, struct pic_reader *); void pic_reader_destroy(pic_state *);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

86
extlib/benz/include/picrin/util.h
View File

@ -1,86 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_UTIL_H
#define PICRIN_UTIL_H
#if defined(__cplusplus)
extern "C" {
#endif
#if __STDC_VERSION__ >= 199901L
# include <stdbool.h>
#else
# define bool char
# define true 1
# define false 0
#endif
#if __STDC_VERSION__ >= 199901L
# include <stddef.h>
#elif ! defined(offsetof)
# define offsetof(s,m) ((size_t)&(((s *)NULL)->m))
#endif
#if __STDC_VERSION__ >= 201112L
# include <stdnoreturn.h>
# define PIC_NORETURN noreturn
#elif __GNUC__ || __clang__
# define PIC_NORETURN __attribute__((noreturn))
#else
# define PIC_NORETURN
#endif
#if __STDC_VERSION__ >= 199901L
# define PIC_INLINE static inline
#elif __GNUC__ || __clang__
# define PIC_INLINE static __inline__
#else
# define PIC_INLINE static
#endif
#define PIC_FALLTHROUGH ((void)0)
#if __GNUC__ || __clang__
# define PIC_UNUSED(v) __attribute__((unused)) v
#else
# define PIC_UNUSED(v) v
#endif
#define PIC_GENSYM2_(x,y) PIC_G##x##_##y##_
#define PIC_GENSYM1_(x,y) PIC_GENSYM2_(x,y)
#if defined(__COUNTER__)
# define PIC_GENSYM(x) PIC_GENSYM1_(__COUNTER__,x)
#else
# define PIC_GENSYM(x) PIC_GENSYM1_(__LINE__,x)
#endif
#if __GNUC__
# define GCC_VERSION (__GNUC__ * 10000 \
+ __GNUC_MINOR__ * 100 \
+ __GNUC_PATCHLEVEL__)
#endif
#if GCC_VERSION >= 40500 || __clang__
# define PIC_UNREACHABLE() (__builtin_unreachable())
#else
# define PIC_UNREACHABLE() (assert(false))
#endif
#if __GNUC__
# undef GCC_VERSION
#endif
#define PIC_SWAP(type,a,b) \
PIC_SWAP_HELPER_(type, PIC_GENSYM(tmp), a, b)
#define PIC_SWAP_HELPER_(type,tmp,a,b) \
do { \
type tmp = (a); \
(a) = (b); \
(b) = tmp; \
} while (0)
#if defined(__cplusplus)
}
#endif
#endif

111
extlib/benz/include/picrin/xfile.h
View File

@ -1,111 +0,0 @@
#ifndef XFILE_H
#define XFILE_H
#if defined(__cplusplus)
extern "C" {
#endif
#include <stdio.h>
#ifndef NULL
# define NULL 0
#endif
#ifndef EOF
# define EOF (-1)
#endif
#define XBUFSIZ 1024
#define XOPEN_MAX 1024
typedef struct {
/* buffer */
char buf[1]; /* fallback buffer */
long cnt; /* characters left */
char *ptr; /* next character position */
char *base; /* location of the buffer */
/* operators */
struct {
void *cookie;
int (*read)(void *, char *, int);
int (*write)(void *, const char *, int);
long (*seek)(void *, long, int);
int (*close)(void *);
} vtable;
int flag; /* mode of the file access */
} xFILE;
extern xFILE x_iob[XOPEN_MAX];
#define xstdin (x_iob[0].vtable.cookie || (x_iob[0].vtable.cookie = stdin ), &x_iob[0])
#define xstdout (x_iob[1].vtable.cookie || (x_iob[1].vtable.cookie = stdout), &x_iob[1])
#define xstderr (x_iob[2].vtable.cookie || (x_iob[2].vtable.cookie = stderr), &x_iob[2])
enum _flags {
X_READ = 01,
X_WRITE = 02,
X_UNBUF = 04,
X_EOF = 010,
X_ERR = 020,
X_LNBUF = 040
};
#define xclearerr(p) ((p)->flag &= ~(X_EOF | X_ERR))
#define xfeof(p) (((p)->flag & X_EOF) != 0)
#define xferror(p) (((p)->flag & X_ERR) != 0)
#define xfileno(p) ((p)->fd)
#define xgetc(p) \
((--(p)->cnt >= 0) \
? (unsigned char) *(p)->ptr++ \
: x_fillbuf(p))
#define xputc(x, p) \
((--(p)->cnt >= 0 && !(((p)->flag & X_LNBUF) && (x) == '\n')) \
? *(p)->ptr++ = (x) \
: x_flushbuf(x, (p)))
#define xgetchar() xgetc(xstdin)
#define xputchar(x) xputc((x), xstdout)
/* resource aquisition */
xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*close)(void *));
xFILE *xfopen(const char *, const char *);
int xfclose(xFILE *);
/* buffer management */
int x_fillbuf(xFILE *);
int x_flushbuf(int, xFILE *);
int xfflush(xFILE *);
/* direct IO */
size_t xfread(void *, size_t, size_t, xFILE *);
size_t xfwrite(const void *, size_t, size_t, xFILE *);
enum {
XSEEK_CUR,
XSEEK_END,
XSEEK_SET
};
/* indicator positioning */
long xfseek(xFILE *, long, int);
long xftell(xFILE *);
void xrewind(xFILE *);
/* character IO */
int xfputc(int, xFILE *);
int xfgetc(xFILE *);
int xfputs(const char *, xFILE *);
char *xfgets(char *, int, xFILE *);
int xputs(const char *);
int xungetc(int, xFILE *);
/* formatted I/O */
int xprintf(const char *, ...);
int xfprintf(xFILE *, const char *, ...);
int xvfprintf(xFILE *, const char *, va_list);
#if defined(__cplusplus)
}
#endif
#endif

13
extlib/benz/lib.c
View File

@ -168,18 +168,6 @@ pic_lib_library_export(pic_state *pic)
return pic_undef_value(); return pic_undef_value();
} }
static pic_value
pic_lib_library_name(pic_state *pic)
{
pic_value lib;
pic_get_args(pic, "o", &lib);
pic_assert_type(pic, lib, lib);
return pic_lib_ptr(lib)->name;
}
static pic_value static pic_value
pic_lib_library_exports(pic_state *pic) pic_lib_library_exports(pic_state *pic)
{ {
@ -215,7 +203,6 @@ pic_init_lib(pic_state *pic)
{ {
pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "make-library", pic_lib_make_library);
pic_defun(pic, "find-library", pic_lib_find_library); pic_defun(pic, "find-library", pic_lib_find_library);
pic_defun(pic, "library-name", pic_lib_library_name);
pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-exports", pic_lib_library_exports);
pic_defun(pic, "library-environment", pic_lib_library_environment); pic_defun(pic, "library-environment", pic_lib_library_environment);

2
extlib/benz/number.c
View File

@ -574,7 +574,7 @@ pic_number_number_to_string(pic_state *pic)
else { else {
struct pic_port *port = pic_open_output_string(pic); struct pic_port *port = pic_open_output_string(pic);
xfprintf(port->file, "%f", f); xfprintf(pic, port->file, "%f", f);
str = pic_get_output_string(pic, port); str = pic_get_output_string(pic, port);

60
extlib/benz/port.c
View File

@ -54,13 +54,12 @@ DEFINE_STANDARD_PORT_ACCESSOR(pic_stdout, "current-output-port")
DEFINE_STANDARD_PORT_ACCESSOR(pic_stderr, "current-error-port") DEFINE_STANDARD_PORT_ACCESSOR(pic_stderr, "current-error-port")
struct strfile { struct strfile {
pic_state *pic;
char *buf; char *buf;
long pos, end, capa; long pos, end, capa;
}; };
static int static int
string_read(void *cookie, char *ptr, int size) string_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size)
{ {
struct strfile *m = cookie; struct strfile *m = cookie;
@ -72,13 +71,13 @@ string_read(void *cookie, char *ptr, int size)
} }
static int static int
string_write(void *cookie, const char *ptr, int size) string_write(pic_state *pic, void *cookie, const char *ptr, int size)
{ {
struct strfile *m = cookie; struct strfile *m = cookie;
if (m->pos + size >= m->capa) { if (m->pos + size >= m->capa) {
m->capa = (m->pos + size) * 2; m->capa = (m->pos + size) * 2;
m->buf = pic_realloc(m->pic, m->buf, (size_t)m->capa); m->buf = pic_realloc(pic, m->buf, (size_t)m->capa);
} }
memcpy(m->buf + m->pos, ptr, size); memcpy(m->buf + m->pos, ptr, size);
m->pos += size; m->pos += size;
@ -88,7 +87,7 @@ string_write(void *cookie, const char *ptr, int size)
} }
static long static long
string_seek(void *cookie, long pos, int whence) string_seek(pic_state PIC_UNUSED(*pic), void *cookie, long pos, int whence)
{ {
struct strfile *m = cookie; struct strfile *m = cookie;
@ -108,12 +107,12 @@ string_seek(void *cookie, long pos, int whence)
} }
static int static int
string_close(void *cookie) string_close(pic_state *pic, void *cookie)
{ {
struct strfile *m = cookie; struct strfile *m = cookie;
pic_free(m->pic, m->buf); pic_free(pic, m->buf);
pic_free(m->pic, m); pic_free(pic, m);
return 0; return 0;
} }
@ -124,7 +123,6 @@ string_open(pic_state *pic, const char *data, size_t size)
xFILE *file; xFILE *file;
m = pic_malloc(pic, sizeof(struct strfile)); m = pic_malloc(pic, sizeof(struct strfile));
m->pic = pic;
m->buf = pic_malloc(pic, size); m->buf = pic_malloc(pic, size);
m->pos = 0; m->pos = 0;
m->end = size; m->end = size;
@ -133,13 +131,13 @@ string_open(pic_state *pic, const char *data, size_t size)
if (data != NULL) { if (data != NULL) {
memcpy(m->buf, data, size); memcpy(m->buf, data, size);
file = xfunopen(m, string_read, NULL, string_seek, string_close); file = xfunopen(pic, m, string_read, NULL, string_seek, string_close);
} else { } else {
file = xfunopen(m, NULL, string_write, string_seek, string_close); file = xfunopen(pic, m, NULL, string_write, string_seek, string_close);
} }
if (file == NULL) { if (file == NULL) {
string_close(m); string_close(pic, m);
pic_error(pic, "could not open new output string/bytevector port", pic_nil_value()); pic_error(pic, "could not open new output string/bytevector port", pic_nil_value());
} }
return file; return file;
@ -178,7 +176,7 @@ pic_get_output_string(pic_state *pic, struct pic_port *port)
pic_errorf(pic, "get-output-string: port is not made by open-output-string"); pic_errorf(pic, "get-output-string: port is not made by open-output-string");
} }
xfflush(port->file); xfflush(pic, port->file);
s = port->file->vtable.cookie; s = port->file->vtable.cookie;
@ -191,7 +189,7 @@ pic_close_port(pic_state *pic, struct pic_port *port)
if ((port->flags & PIC_PORT_OPEN) == 0) { if ((port->flags & PIC_PORT_OPEN) == 0) {
return; return;
} }
if (xfclose(port->file) == EOF) { if (xfclose(pic, port->file) == EOF) {
pic_errorf(pic, "close-port: failure"); pic_errorf(pic, "close-port: failure");
} }
port->flags &= ~PIC_PORT_OPEN; port->flags &= ~PIC_PORT_OPEN;
@ -431,7 +429,7 @@ pic_port_get_output_bytevector(pic_state *pic)
pic_errorf(pic, "get-output-bytevector: port is not made by open-output-bytevector"); pic_errorf(pic, "get-output-bytevector: port is not made by open-output-bytevector");
} }
xfflush(port->file); xfflush(pic, port->file);
s = port->file->vtable.cookie; s = port->file->vtable.cookie;
@ -451,7 +449,7 @@ pic_port_read_char(pic_state *pic)
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-char"); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-char");
if ((c = xfgetc(port->file)) == EOF) { if ((c = xfgetc(pic, port->file)) == EOF) {
return pic_eof_object(); return pic_eof_object();
} }
else { else {
@ -469,7 +467,7 @@ pic_port_peek_char(pic_state *pic)
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "peek-char"); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "peek-char");
if ((c = xfgetc(port->file)) == EOF) { if ((c = xfgetc(pic, port->file)) == EOF) {
return pic_eof_object(); return pic_eof_object();
} }
else { else {
@ -490,8 +488,8 @@ pic_port_read_line(pic_state *pic)
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-line"); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, "read-line");
buf = pic_open_output_string(pic); buf = pic_open_output_string(pic);
while ((c = xfgetc(port->file)) != EOF && c != '\n') { while ((c = xfgetc(pic, port->file)) != EOF && c != '\n') {
xfputc(c, buf->file); xfputc(pic, c, buf->file);
} }
str = pic_get_output_string(pic, buf); str = pic_get_output_string(pic, buf);
@ -529,10 +527,10 @@ pic_port_read_string(pic_state *pic){
c = EOF; c = EOF;
buf = pic_open_output_string(pic); buf = pic_open_output_string(pic);
for(i = 0; i < k; ++i) { for(i = 0; i < k; ++i) {
if((c = xfgetc(port->file)) == EOF){ if((c = xfgetc(pic, port->file)) == EOF){
break; break;
} }
xfputc(c, buf->file); xfputc(pic, c, buf->file);
} }
str = pic_get_output_string(pic, buf); str = pic_get_output_string(pic, buf);
@ -552,7 +550,7 @@ pic_port_read_byte(pic_state *pic){
pic_get_args(pic, "|p", &port); pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-u8"); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "read-u8");
if ((c = xfgetc(port->file)) == EOF) { if ((c = xfgetc(pic, port->file)) == EOF) {
return pic_eof_object(); return pic_eof_object();
} }
@ -569,7 +567,7 @@ pic_port_peek_byte(pic_state *pic)
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "peek-u8"); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, "peek-u8");
c = xfgetc(port->file); c = xfgetc(pic, port->file);
if (c == EOF) { if (c == EOF) {
return pic_eof_object(); return pic_eof_object();
} }
@ -605,7 +603,7 @@ pic_port_read_blob(pic_state *pic)
blob = pic_make_blob(pic, k); blob = pic_make_blob(pic, k);
i = xfread(blob->data, sizeof(char), k, port->file); i = xfread(pic, blob->data, sizeof(char), k, port->file);
if (i == 0) { if (i == 0) {
return pic_eof_object(); return pic_eof_object();
} }
@ -644,7 +642,7 @@ pic_port_read_blob_ip(pic_state *pic)
len = end - start; len = end - start;
buf = pic_calloc(pic, len, sizeof(char)); buf = pic_calloc(pic, len, sizeof(char));
i = xfread(buf, sizeof(char), len, port->file); i = xfread(pic, buf, sizeof(char), len, port->file);
memcpy(bv->data + start, buf, i); memcpy(bv->data + start, buf, i);
pic_free(pic, buf); pic_free(pic, buf);
@ -665,7 +663,7 @@ pic_port_newline(pic_state *pic)
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "newline"); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "newline");
xfputs("\n", port->file); xfputs(pic, "\n", port->file);
return pic_undef_value(); return pic_undef_value();
} }
@ -679,7 +677,7 @@ pic_port_write_char(pic_state *pic)
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-char"); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-char");
xfputc(c, port->file); xfputc(pic, c, port->file);
return pic_undef_value(); return pic_undef_value();
} }
@ -703,7 +701,7 @@ pic_port_write_string(pic_state *pic)
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-string"); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, "write-string");
for (i = start; i < end && str[i] != '\0'; ++i) { for (i = start; i < end && str[i] != '\0'; ++i) {
xfputc(str[i], port->file); xfputc(pic, str[i], port->file);
} }
return pic_undef_value(); return pic_undef_value();
} }
@ -718,7 +716,7 @@ pic_port_write_byte(pic_state *pic)
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-u8"); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-u8");
xfputc(i, port->file); xfputc(pic, i, port->file);
return pic_undef_value(); return pic_undef_value();
} }
@ -743,7 +741,7 @@ pic_port_write_blob(pic_state *pic)
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-bytevector"); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, "write-bytevector");
for (i = start; i < end; ++i) { for (i = start; i < end; ++i) {
xfputc(blob->data[i], port->file); xfputc(pic, blob->data[i], port->file);
} }
return pic_undef_value(); return pic_undef_value();
} }
@ -757,7 +755,7 @@ pic_port_flush(pic_state *pic)
assert_port_profile(port, PIC_PORT_OUT, "flush-output-port"); assert_port_profile(port, PIC_PORT_OUT, "flush-output-port");
xfflush(port->file); xfflush(pic, port->file);
return pic_undef_value(); return pic_undef_value();
} }

211
extlib/benz/read.c
View File

@ -18,39 +18,39 @@ read_error(pic_state *pic, const char *msg)
} }
static int static int
skip(struct pic_port *port, int c) skip(pic_state *pic, struct pic_port *port, int c)
{ {
while (isspace(c)) { while (isspace(c)) {
c = xfgetc(port->file); c = xfgetc(pic, port->file);
} }
return c; return c;
} }
static int static int
next(struct pic_port *port) next(pic_state *pic, struct pic_port *port)
{ {
return xfgetc(port->file); return xfgetc(pic, port->file);
} }
static int static int
peek(struct pic_port *port) peek(pic_state *pic, struct pic_port *port)
{ {
int c; int c;
xungetc((c = xfgetc(port->file)), port->file); xungetc((c = xfgetc(pic, port->file)), port->file);
return c; return c;
} }
static bool static bool
expect(struct pic_port *port, const char *str) expect(pic_state *pic, struct pic_port *port, const char *str)
{ {
int c; int c;
while ((c = (int)*str++) != 0) { while ((c = (int)*str++) != 0) {
if (c != peek(port)) if (c != peek(pic, port))
return false; return false;
next(port); next(pic, port);
} }
return true; return true;
@ -79,7 +79,7 @@ strcaseeq(const char *s1, const char *s2)
static int static int
case_fold(pic_state *pic, int c) case_fold(pic_state *pic, int c)
{ {
if (pic->reader->typecase == PIC_CASE_FOLD) { if (pic->reader.typecase == PIC_CASE_FOLD) {
c = tolower(c); c = tolower(c);
} }
return c; return c;
@ -89,7 +89,7 @@ static pic_value
read_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int c) read_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int c)
{ {
do { do {
c = next(port); c = next(pic, port);
} while (! (c == EOF || c == '\n')); } while (! (c == EOF || c == '\n'));
return pic_invalid_value(); return pic_invalid_value();
@ -101,11 +101,11 @@ read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UN
int x, y; int x, y;
int i = 1; int i = 1;
y = next(port); y = next(pic, port);
while (y != EOF && i > 0) { while (y != EOF && i > 0) {
x = y; x = y;
y = next(port); y = next(pic, port);
if (x == '|' && y == '#') { if (x == '|' && y == '#') {
i--; i--;
} }
@ -120,7 +120,7 @@ read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UN
static pic_value static pic_value
read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
read(pic, port, next(port)); read(pic, port, next(pic, port));
return pic_invalid_value(); return pic_invalid_value();
} }
@ -128,16 +128,16 @@ read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
static pic_value static pic_value
read_directive(pic_state *pic, struct pic_port *port, int c) read_directive(pic_state *pic, struct pic_port *port, int c)
{ {
switch (peek(port)) { switch (peek(pic, port)) {
case 'n': case 'n':
if (expect(port, "no-fold-case")) { if (expect(pic, port, "no-fold-case")) {
pic->reader->typecase = PIC_CASE_DEFAULT; pic->reader.typecase = PIC_CASE_DEFAULT;
return pic_invalid_value(); return pic_invalid_value();
} }
break; break;
case 'f': case 'f':
if (expect(port, "fold-case")) { if (expect(pic, port, "fold-case")) {
pic->reader->typecase = PIC_CASE_FOLD; pic->reader.typecase = PIC_CASE_FOLD;
return pic_invalid_value(); return pic_invalid_value();
} }
break; break;
@ -149,13 +149,13 @@ read_directive(pic_state *pic, struct pic_port *port, int c)
static pic_value static pic_value
read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(pic, port)));
} }
static pic_value static pic_value
read_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) read_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(pic, port)));
} }
static pic_value static pic_value
@ -163,23 +163,23 @@ read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
pic_sym *tag = pic->sUNQUOTE; pic_sym *tag = pic->sUNQUOTE;
if (peek(port) == '@') { if (peek(pic, port) == '@') {
tag = pic->sUNQUOTE_SPLICING; tag = pic->sUNQUOTE_SPLICING;
next(port); next(pic, port);
} }
return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(pic, port)));
} }
static pic_value static pic_value
read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(pic, port)));
} }
static pic_value static pic_value
read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(pic, port)));
} }
static pic_value static pic_value
@ -187,11 +187,11 @@ read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{ {
pic_sym *tag = pic->sSYNTAX_UNQUOTE; pic_sym *tag = pic->sSYNTAX_UNQUOTE;
if (peek(port) == '@') { if (peek(pic, port) == '@') {
tag = pic->sSYNTAX_UNQUOTE_SPLICING; tag = pic->sSYNTAX_UNQUOTE_SPLICING;
next(port); next(pic, port);
} }
return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(pic, port)));
} }
static pic_value static pic_value
@ -206,8 +206,8 @@ read_symbol(pic_state *pic, struct pic_port *port, int c)
buf[0] = case_fold(pic, c); buf[0] = case_fold(pic, c);
buf[1] = 0; buf[1] = 0;
while (! isdelim(peek(port))) { while (! isdelim(peek(pic, port))) {
c = next(port); c = next(pic, port);
len += 1; len += 1;
buf = pic_realloc(pic, buf, len + 1); buf = pic_realloc(pic, buf, len + 1);
buf[len - 1] = case_fold(pic, c); buf[len - 1] = case_fold(pic, c);
@ -230,8 +230,8 @@ read_uinteger(pic_state *pic, struct pic_port *port, int c)
} }
u = c - '0'; u = c - '0';
while (isdigit(c = peek(port))) { while (isdigit(c = peek(pic, port))) {
u = u * 10 + next(port) - '0'; u = u * 10 + next(pic, port) - '0';
} }
return u; return u;
@ -242,19 +242,19 @@ read_suffix(pic_state *pic, struct pic_port *port)
{ {
int c, s = 1; int c, s = 1;
c = peek(port); c = peek(pic, port);
if (c != 'e' && c != 'E') { if (c != 'e' && c != 'E') {
return 0; return 0;
} }
next(port); next(pic, port);
switch ((c = next(port))) { switch ((c = next(pic, port))) {
case '-': case '-':
s = -1; s = -1;
case '+': case '+':
c = next(port); c = next(pic, port);
default: default:
return s * read_uinteger(pic, port, c); return s * read_uinteger(pic, port, c);
} }
@ -271,13 +271,13 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
u = read_uinteger(pic, port, c); u = read_uinteger(pic, port, c);
switch (peek(port)) { switch (peek(pic, port)) {
#if PIC_ENABLE_FLOAT #if PIC_ENABLE_FLOAT
case '.': case '.':
next(port); next(pic, port);
g = 0, e = 0; g = 0, e = 0;
while (isdigit(c = peek(port))) { while (isdigit(c = peek(pic, port))) {
g = g * 10 + (next(port) - '0'); g = g * 10 + (next(pic, port) - '0');
e++; e++;
} }
f = u + g * pow(10, -e); f = u + g * pow(10, -e);
@ -348,8 +348,8 @@ read_minus(pic_state *pic, struct pic_port *port, int c)
{ {
pic_value sym; pic_value sym;
if (isdigit(peek(port))) { if (isdigit(peek(pic, port))) {
return negate(read_unsigned(pic, port, next(port))); return negate(read_unsigned(pic, port, next(pic, port)));
} }
else { else {
sym = read_symbol(pic, port, c); sym = read_symbol(pic, port, c);
@ -370,8 +370,8 @@ read_plus(pic_state *pic, struct pic_port *port, int c)
{ {
pic_value sym; pic_value sym;
if (isdigit(peek(port))) { if (isdigit(peek(pic, port))) {
return read_unsigned(pic, port, next(port)); return read_unsigned(pic, port, next(pic, port));
} }
else { else {
sym = read_symbol(pic, port, c); sym = read_symbol(pic, port, c);
@ -390,8 +390,8 @@ read_plus(pic_state *pic, struct pic_port *port, int c)
static pic_value static pic_value
read_true(pic_state *pic, struct pic_port *port, int c) read_true(pic_state *pic, struct pic_port *port, int c)
{ {
if ((c = peek(port)) == 'r') { if ((c = peek(pic, port)) == 'r') {
if (! expect(port, "rue")) { if (! expect(pic, port, "rue")) {
read_error(pic, "unexpected character while reading #true"); read_error(pic, "unexpected character while reading #true");
} }
} else if (! isdelim(c)) { } else if (! isdelim(c)) {
@ -404,8 +404,8 @@ read_true(pic_state *pic, struct pic_port *port, int c)
static pic_value static pic_value
read_false(pic_state *pic, struct pic_port *port, int c) read_false(pic_state *pic, struct pic_port *port, int c)
{ {
if ((c = peek(port)) == 'a') { if ((c = peek(pic, port)) == 'a') {
if (! expect(port, "alse")) { if (! expect(pic, port, "alse")) {
read_error(pic, "unexpected character while reading #false"); read_error(pic, "unexpected character while reading #false");
} }
} else if (! isdelim(c)) { } else if (! isdelim(c)) {
@ -418,29 +418,29 @@ read_false(pic_state *pic, struct pic_port *port, int c)
static pic_value static pic_value
read_char(pic_state *pic, struct pic_port *port, int c) read_char(pic_state *pic, struct pic_port *port, int c)
{ {
c = next(port); c = next(pic, port);
if (! isdelim(peek(port))) { if (! isdelim(peek(pic, port))) {
switch (c) { switch (c) {
default: read_error(pic, "unexpected character after char literal"); default: read_error(pic, "unexpected character after char literal");
case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break; case 'a': c = '\a'; if (! expect(pic, port, "lerm")) goto fail; break;
case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break; case 'b': c = '\b'; if (! expect(pic, port, "ackspace")) goto fail; break;
case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break; case 'd': c = 0x7F; if (! expect(pic, port, "elete")) goto fail; break;
case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break; case 'e': c = 0x1B; if (! expect(pic, port, "scape")) goto fail; break;
case 'n': case 'n':
if ((c = peek(port)) == 'e') { if ((c = peek(pic, port)) == 'e') {
c = '\n'; c = '\n';
if (! expect(port, "ewline")) if (! expect(pic, port, "ewline"))
goto fail; goto fail;
} else { } else {
c = '\0'; c = '\0';
if (! expect(port, "ull")) if (! expect(pic, port, "ull"))
goto fail; goto fail;
} }
break; break;
case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break; case 'r': c = '\r'; if (! expect(pic, port, "eturn")) goto fail; break;
case 's': c = ' '; if (! expect(port, "pace")) goto fail; break; case 's': c = ' '; if (! expect(pic, port, "pace")) goto fail; break;
case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break; case 't': c = '\t'; if (! expect(pic, port, "ab")) goto fail; break;
} }
} }
@ -463,9 +463,9 @@ read_string(pic_state *pic, struct pic_port *port, int c)
/* TODO: intraline whitespaces */ /* TODO: intraline whitespaces */
while ((c = next(port)) != '"') { while ((c = next(pic, port)) != '"') {
if (c == '\\') { if (c == '\\') {
switch (c = next(port)) { switch (c = next(pic, port)) {
case 'a': c = '\a'; break; case 'a': c = '\a'; break;
case 'b': c = '\b'; break; case 'b': c = '\b'; break;
case 't': c = '\t'; break; case 't': c = '\t'; break;
@ -498,9 +498,9 @@ read_pipe(pic_state *pic, struct pic_port *port, int c)
size = 256; size = 256;
buf = pic_malloc(pic, size); buf = pic_malloc(pic, size);
cnt = 0; cnt = 0;
while ((c = next(port)) != '|') { while ((c = next(pic, port)) != '|') {
if (c == '\\') { if (c == '\\') {
switch ((c = next(port))) { switch ((c = next(pic, port))) {
case 'a': c = '\a'; break; case 'a': c = '\a'; break;
case 'b': c = '\b'; break; case 'b': c = '\b'; break;
case 't': c = '\t'; break; case 't': c = '\t'; break;
@ -508,7 +508,7 @@ read_pipe(pic_state *pic, struct pic_port *port, int c)
case 'r': c = '\r'; break; case 'r': c = '\r'; break;
case 'x': case 'x':
i = 0; i = 0;
while ((HEX_BUF[i++] = (char)next(port)) != ';') { while ((HEX_BUF[i++] = (char)next(pic, port)) != ';') {
if (i >= sizeof HEX_BUF) if (i >= sizeof HEX_BUF)
read_error(pic, "expected ';'"); read_error(pic, "expected ';'");
} }
@ -539,7 +539,7 @@ read_blob(pic_state *pic, struct pic_port *port, int c)
nbits = 0; nbits = 0;
while (isdigit(c = next(port))) { while (isdigit(c = next(pic, port))) {
nbits = 10 * nbits + c - '0'; nbits = 10 * nbits + c - '0';
} }
@ -553,8 +553,8 @@ read_blob(pic_state *pic, struct pic_port *port, int c)
len = 0; len = 0;
dat = NULL; dat = NULL;
c = next(port); c = next(pic, port);
while ((c = skip(port, c)) != ')') { while ((c = skip(pic, port, c)) != ')') {
n = read_uinteger(pic, port, c); n = read_uinteger(pic, port, c);
if (n < 0 || (1 << nbits) <= n) { if (n < 0 || (1 << nbits) <= n) {
read_error(pic, "invalid element in bytevector literal"); read_error(pic, "invalid element in bytevector literal");
@ -562,7 +562,7 @@ read_blob(pic_state *pic, struct pic_port *port, int c)
len += 1; len += 1;
dat = pic_realloc(pic, dat, len); dat = pic_realloc(pic, dat, len);
dat[len - 1] = (unsigned char)n; dat[len - 1] = (unsigned char)n;
c = next(port); c = next(pic, port);
} }
blob = pic_make_blob(pic, len); blob = pic_make_blob(pic, len);
@ -577,8 +577,8 @@ read_blob(pic_state *pic, struct pic_port *port, int c)
static pic_value static pic_value
read_undef_or_blob(pic_state *pic, struct pic_port *port, int c) read_undef_or_blob(pic_state *pic, struct pic_port *port, int c)
{ {
if ((c = peek(port)) == 'n') { if ((c = peek(pic, port)) == 'n') {
if (! expect(port, "ndefined")) { if (! expect(pic, port, "ndefined")) {
read_error(pic, "unexpected character while reading #undefined"); read_error(pic, "unexpected character while reading #undefined");
} }
return pic_undef_value(); return pic_undef_value();
@ -597,16 +597,16 @@ read_pair(pic_state *pic, struct pic_port *port, int c)
retry: retry:
c = skip(port, ' '); c = skip(pic, port, ' ');
if (c == tCLOSE) { if (c == tCLOSE) {
return pic_nil_value(); return pic_nil_value();
} }
if (c == '.' && isdelim(peek(port))) { if (c == '.' && isdelim(peek(pic, port))) {
cdr = read(pic, port, next(port)); cdr = read(pic, port, next(pic, port));
closing: closing:
if ((c = skip(port, ' ')) != tCLOSE) { if ((c = skip(pic, port, ' ')) != tCLOSE) {
if (pic_invalid_p(read_nullable(pic, port, c))) { if (pic_invalid_p(read_nullable(pic, port, c))) {
goto closing; goto closing;
} }
@ -642,14 +642,14 @@ read_label_set(pic_state *pic, struct pic_port *port, int i)
pic_value val; pic_value val;
int c; int c;
switch ((c = skip(port, ' '))) { switch ((c = skip(pic, port, ' '))) {
case '(': case '(':
{ {
pic_value tmp; pic_value tmp;
val = pic_cons(pic, pic_undef_value(), pic_undef_value()); val = pic_cons(pic, pic_undef_value(), pic_undef_value());
xh_put_int(&pic->reader->labels, i, &val); xh_put_int(&pic->reader.labels, i, &val);
tmp = read(pic, port, c); tmp = read(pic, port, c);
pic_pair_ptr(val)->car = pic_car(pic, tmp); pic_pair_ptr(val)->car = pic_car(pic, tmp);
@ -661,7 +661,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i)
{ {
bool vect; bool vect;
if (peek(port) == '(') { if (peek(pic, port) == '(') {
vect = true; vect = true;
} else { } else {
vect = false; vect = false;
@ -672,7 +672,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i)
val = pic_obj_value(pic_make_vec(pic, 0)); val = pic_obj_value(pic_make_vec(pic, 0));
xh_put_int(&pic->reader->labels, i, &val); xh_put_int(&pic->reader.labels, i, &val);
tmp = pic_vec_ptr(read(pic, port, c)); tmp = pic_vec_ptr(read(pic, port, c));
PIC_SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); PIC_SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
@ -687,7 +687,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i)
{ {
val = read(pic, port, c); val = read(pic, port, c);
xh_put_int(&pic->reader->labels, i, &val); xh_put_int(&pic->reader.labels, i, &val);
return val; return val;
} }
@ -699,7 +699,7 @@ read_label_ref(pic_state *pic, struct pic_port PIC_UNUSED(*port), int i)
{ {
xh_entry *e; xh_entry *e;
e = xh_get_int(&pic->reader->labels, i); e = xh_get_int(&pic->reader.labels, i);
if (! e) { if (! e) {
read_error(pic, "label of given index not defined"); read_error(pic, "label of given index not defined");
} }
@ -714,7 +714,7 @@ read_label(pic_state *pic, struct pic_port *port, int c)
i = 0; i = 0;
do { do {
i = i * 10 + c - '0'; i = i * 10 + c - '0';
} while (isdigit(c = next(port))); } while (isdigit(c = next(pic, port)));
if (c == '=') { if (c == '=') {
return read_label_set(pic, port, i); return read_label_set(pic, port, i);
@ -734,33 +734,33 @@ read_unmatch(pic_state *pic, struct pic_port PIC_UNUSED(*port), int PIC_UNUSED(c
static pic_value static pic_value
read_dispatch(pic_state *pic, struct pic_port *port, int c) read_dispatch(pic_state *pic, struct pic_port *port, int c)
{ {
c = next(port); c = next(pic, port);
if (c == EOF) { if (c == EOF) {
read_error(pic, "unexpected EOF"); read_error(pic, "unexpected EOF");
} }
if (pic->reader->dispatch[c] == NULL) { if (pic->reader.dispatch[c] == NULL) {
read_error(pic, "invalid character at the seeker head"); read_error(pic, "invalid character at the seeker head");
} }
return pic->reader->dispatch[c](pic, port, c); return pic->reader.dispatch[c](pic, port, c);
} }
static pic_value static pic_value
read_nullable(pic_state *pic, struct pic_port *port, int c) read_nullable(pic_state *pic, struct pic_port *port, int c)
{ {
c = skip(port, c); c = skip(pic, port, c);
if (c == EOF) { if (c == EOF) {
read_error(pic, "unexpected EOF"); read_error(pic, "unexpected EOF");
} }
if (pic->reader->table[c] == NULL) { if (pic->reader.table[c] == NULL) {
read_error(pic, "invalid character at the seeker head"); read_error(pic, "invalid character at the seeker head");
} }
return pic->reader->table[c](pic, port, c); return pic->reader.table[c](pic, port, c);
} }
static pic_value static pic_value
@ -772,7 +772,7 @@ read(pic_state *pic, struct pic_port *port, int c)
val = read_nullable(pic, port, c); val = read_nullable(pic, port, c);
if (pic_invalid_p(val)) { if (pic_invalid_p(val)) {
c = next(port); c = next(pic, port);
goto retry; goto retry;
} }
@ -780,7 +780,7 @@ read(pic_state *pic, struct pic_port *port, int c)
} }
static void static void
reader_table_init(struct pic_reader *reader) reader_table_init(pic_reader *reader)
{ {
int c; int c;
@ -826,44 +826,39 @@ reader_table_init(struct pic_reader *reader)
} }
} }
struct pic_reader * void
pic_reader_open(pic_state *pic) pic_reader_init(pic_state *pic)
{ {
struct pic_reader *reader;
int c; int c;
reader = pic_malloc(pic, sizeof(struct pic_reader)); pic->reader.typecase = PIC_CASE_DEFAULT;
reader->typecase = PIC_CASE_DEFAULT; xh_init_int(&pic->reader.labels, sizeof(pic_value));
xh_init_int(&reader->labels, sizeof(pic_value));
for (c = 0; c < 256; ++c) { for (c = 0; c < 256; ++c) {
reader->table[c] = NULL; pic->reader.table[c] = NULL;
} }
for (c = 0; c < 256; ++c) { for (c = 0; c < 256; ++c) {
reader->dispatch[c] = NULL; pic->reader.dispatch[c] = NULL;
} }
reader_table_init(reader); reader_table_init(&pic->reader);
return reader;
} }
void void
pic_reader_close(pic_state *pic, struct pic_reader *reader) pic_reader_destroy(pic_state *pic)
{ {
xh_destroy(&reader->labels); xh_destroy(&pic->reader.labels);
pic_free(pic, reader);
} }
pic_value pic_value
pic_read(pic_state *pic, struct pic_port *port) pic_read(pic_state *pic, struct pic_port *port)
{ {
pic_value val; pic_value val;
int c = next(port); int c = next(pic, port);
retry: retry:
c = skip(port, c); c = skip(pic, port, c);
if (c == EOF) { if (c == EOF) {
return pic_eof_object(); return pic_eof_object();
@ -872,7 +867,7 @@ pic_read(pic_state *pic, struct pic_port *port)
val = read_nullable(pic, port, c); val = read_nullable(pic, port, c);
if (pic_invalid_p(val)) { if (pic_invalid_p(val)) {
c = next(port); c = next(pic, port);
goto retry; goto retry;
} }

24
extlib/benz/state.c
View File

@ -216,13 +216,6 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
goto EXIT_ARENA; goto EXIT_ARENA;
} }
/* trampoline iseq */
pic->iseq = allocf(NULL, 2 * sizeof(pic_code));
if (! pic->iseq) {
goto EXIT_ISEQ;
}
/* memory heap */ /* memory heap */
pic->heap = pic_heap_open(pic); pic->heap = pic_heap_open(pic);
@ -254,6 +247,12 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
/* raised error object */ /* raised error object */
pic->err = pic_invalid_value(); pic->err = pic_invalid_value();
/* file pool */
memcpy(pic->files, x_iob, sizeof pic->files);
pic->files[0].vtable.cookie = stdin;
pic->files[1].vtable.cookie = stdout;
pic->files[2].vtable.cookie = stderr;
/* parameter table */ /* parameter table */
pic->ptable = pic_nil_value(); pic->ptable = pic_nil_value();
@ -365,7 +364,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
pic->cp->in = pic->cp->out = NULL; pic->cp->in = pic->cp->out = NULL;
/* reader */ /* reader */
pic->reader = pic_reader_open(pic); pic_reader_init(pic);
/* parameter table */ /* parameter table */
pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable); pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable);
@ -387,8 +386,6 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
return pic; return pic;
EXIT_ISEQ:
allocf(pic->arena, 0);
EXIT_ARENA: EXIT_ARENA:
allocf(pic->xp, 0); allocf(pic->xp, 0);
EXIT_XP: EXIT_XP:
@ -437,22 +434,19 @@ pic_close(pic_state *pic)
pic_gc_run(pic); pic_gc_run(pic);
/* flush all xfiles */ /* flush all xfiles */
xfflush(NULL); xfflush(pic, NULL);
/* free heaps */ /* free heaps */
pic_heap_close(pic, pic->heap); pic_heap_close(pic, pic->heap);
/* free reader struct */ /* free reader struct */
pic_reader_close(pic, pic->reader); pic_reader_destroy(pic);
/* free runtime context */ /* free runtime context */
allocf(pic->stbase, 0); allocf(pic->stbase, 0);
allocf(pic->cibase, 0); allocf(pic->cibase, 0);
allocf(pic->xpbase, 0); allocf(pic->xpbase, 0);
/* free trampoline iseq */
allocf(pic->iseq, 0);
/* free global stacks */ /* free global stacks */
xh_destroy(&pic->syms); xh_destroy(&pic->syms);

22
extlib/benz/string.c
View File

@ -310,7 +310,7 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
while ((c = *fmt++)) { while ((c = *fmt++)) {
switch (c) { switch (c) {
default: default:
xfputc(c, file); xfputc(pic, c, file);
break; break;
case '%': case '%':
c = *fmt++; c = *fmt++;
@ -318,26 +318,26 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
goto exit; goto exit;
switch (c) { switch (c) {
default: default:
xfputc(c, file); xfputc(pic, c, file);
break; break;
case '%': case '%':
xfputc('%', file); xfputc(pic, '%', file);
break; break;
case 'c': case 'c':
xfprintf(file, "%c", va_arg(ap, int)); xfprintf(pic, file, "%c", va_arg(ap, int));
break; break;
case 's': case 's':
xfprintf(file, "%s", va_arg(ap, const char *)); xfprintf(pic, file, "%s", va_arg(ap, const char *));
break; break;
case 'd': case 'd':
xfprintf(file, "%d", va_arg(ap, int)); xfprintf(pic, file, "%d", va_arg(ap, int));
break; break;
case 'p': case 'p':
xfprintf(file, "%p", va_arg(ap, void *)); xfprintf(pic, file, "%p", va_arg(ap, void *));
break; break;
#if PIC_ENABLE_FLOAT #if PIC_ENABLE_FLOAT
case 'f': case 'f':
xfprintf(file, "%f", va_arg(ap, double)); xfprintf(pic, file, "%f", va_arg(ap, double));
break; break;
#endif #endif
} }
@ -348,13 +348,13 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
goto exit; goto exit;
switch (c) { switch (c) {
default: default:
xfputc(c, file); xfputc(pic, c, file);
break; break;
case '~': case '~':
xfputc('~', file); xfputc(pic, '~', file);
break; break;
case '%': case '%':
xfputc('\n', file); xfputc(pic, '\n', file);
break; break;
case 'a': case 'a':
irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs); irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs);

109
extlib/benz/write.c
View File

@ -111,6 +111,7 @@ static void write_core(struct writer_control *p, pic_value);
static void static void
write_pair(struct writer_control *p, struct pic_pair *pair) write_pair(struct writer_control *p, struct pic_pair *pair)
{ {
pic_state *pic = p->pic;
xh_entry *e; xh_entry *e;
int c; int c;
@ -123,27 +124,27 @@ write_pair(struct writer_control *p, struct pic_pair *pair)
/* shared objects */ /* shared objects */
if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) { if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) {
xfprintf(p->file, " . "); xfprintf(pic, p->file, " . ");
if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) { if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) {
xfprintf(p->file, "#%d#", xh_val(e, int)); xfprintf(pic, p->file, "#%d#", xh_val(e, int));
return; return;
} }
else { else {
xfprintf(p->file, "#%d=", xh_val(e, int)); xfprintf(pic, p->file, "#%d=", xh_val(e, int));
c = 1; c = 1;
xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c); xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c);
} }
} }
else { else {
xfprintf(p->file, " "); xfprintf(pic, p->file, " ");
} }
write_pair(p, pic_pair_ptr(pair->cdr)); write_pair(p, pic_pair_ptr(pair->cdr));
return; return;
} }
else { else {
xfprintf(p->file, " . "); xfprintf(pic, p->file, " . ");
write_core(p, pair->cdr); write_core(p, pair->cdr);
} }
} }
@ -156,9 +157,9 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file)
for (i = 0; i < pic_str_len(str); ++i) { for (i = 0; i < pic_str_len(str); ++i) {
if (cstr[i] == '"' || cstr[i] == '\\') { if (cstr[i] == '"' || cstr[i] == '\\') {
xfputc('\\', file); xfputc(pic, '\\', file);
} }
xfputc(cstr[i], file); xfputc(pic, cstr[i], file);
} }
} }
@ -179,11 +180,11 @@ write_core(struct writer_control *p, pic_value obj)
&& (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj))) && (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)))
&& xh_val(e, int) != -1) { && xh_val(e, int) != -1) {
if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) { if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) {
xfprintf(file, "#%d#", xh_val(e, int)); xfprintf(pic, file, "#%d#", xh_val(e, int));
return; return;
} }
else { else {
xfprintf(file, "#%d=", xh_val(e, int)); xfprintf(pic, file, "#%d=", xh_val(e, int));
c = 1; c = 1;
xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c); xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c);
} }
@ -191,122 +192,122 @@ write_core(struct writer_control *p, pic_value obj)
switch (pic_type(obj)) { switch (pic_type(obj)) {
case PIC_TT_UNDEF: case PIC_TT_UNDEF:
xfprintf(file, "#undefined"); xfprintf(pic, file, "#undefined");
break; break;
case PIC_TT_NIL: case PIC_TT_NIL:
xfprintf(file, "()"); xfprintf(pic, file, "()");
break; break;
case PIC_TT_BOOL: case PIC_TT_BOOL:
if (pic_true_p(obj)) if (pic_true_p(obj))
xfprintf(file, "#t"); xfprintf(pic, file, "#t");
else else
xfprintf(file, "#f"); xfprintf(pic, file, "#f");
break; break;
case PIC_TT_PAIR: case PIC_TT_PAIR:
if (is_quote(pic, obj)) { if (is_quote(pic, obj)) {
xfprintf(file, "'"); xfprintf(pic, file, "'");
write_core(p, pic_list_ref(pic, obj, 1)); write_core(p, pic_list_ref(pic, obj, 1));
break; break;
} }
else if (is_unquote(pic, obj)) { else if (is_unquote(pic, obj)) {
xfprintf(file, ","); xfprintf(pic, file, ",");
write_core(p, pic_list_ref(pic, obj, 1)); write_core(p, pic_list_ref(pic, obj, 1));
break; break;
} }
else if (is_unquote_splicing(pic, obj)) { else if (is_unquote_splicing(pic, obj)) {
xfprintf(file, ",@"); xfprintf(pic, file, ",@");
write_core(p, pic_list_ref(pic, obj, 1)); write_core(p, pic_list_ref(pic, obj, 1));
break; break;
} }
else if (is_quasiquote(pic, obj)) { else if (is_quasiquote(pic, obj)) {
xfprintf(file, "`"); xfprintf(pic, file, "`");
write_core(p, pic_list_ref(pic, obj, 1)); write_core(p, pic_list_ref(pic, obj, 1));
break; break;
} }
xfprintf(file, "("); xfprintf(pic, file, "(");
write_pair(p, pic_pair_ptr(obj)); write_pair(p, pic_pair_ptr(obj));
xfprintf(file, ")"); xfprintf(pic, file, ")");
break; break;
case PIC_TT_SYMBOL: case PIC_TT_SYMBOL:
xfprintf(file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj)));
break; break;
case PIC_TT_CHAR: case PIC_TT_CHAR:
if (p->mode == DISPLAY_MODE) { if (p->mode == DISPLAY_MODE) {
xfputc(pic_char(obj), file); xfputc(pic, pic_char(obj), file);
break; break;
} }
switch (pic_char(obj)) { switch (pic_char(obj)) {
default: xfprintf(file, "#\\%c", pic_char(obj)); break; default: xfprintf(pic, file, "#\\%c", pic_char(obj)); break;
case '\a': xfprintf(file, "#\\alarm"); break; case '\a': xfprintf(pic, file, "#\\alarm"); break;
case '\b': xfprintf(file, "#\\backspace"); break; case '\b': xfprintf(pic, file, "#\\backspace"); break;
case 0x7f: xfprintf(file, "#\\delete"); break; case 0x7f: xfprintf(pic, file, "#\\delete"); break;
case 0x1b: xfprintf(file, "#\\escape"); break; case 0x1b: xfprintf(pic, file, "#\\escape"); break;
case '\n': xfprintf(file, "#\\newline"); break; case '\n': xfprintf(pic, file, "#\\newline"); break;
case '\r': xfprintf(file, "#\\return"); break; case '\r': xfprintf(pic, file, "#\\return"); break;
case ' ': xfprintf(file, "#\\space"); break; case ' ': xfprintf(pic, file, "#\\space"); break;
case '\t': xfprintf(file, "#\\tab"); break; case '\t': xfprintf(pic, file, "#\\tab"); break;
} }
break; break;
#if PIC_ENABLE_FLOAT #if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
f = pic_float(obj); f = pic_float(obj);
if (isnan(f)) { if (isnan(f)) {
xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0"); xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0");
} else if (isinf(f)) { } else if (isinf(f)) {
xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0"); xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0");
} else { } else {
xfprintf(file, "%f", pic_float(obj)); xfprintf(pic, file, "%f", pic_float(obj));
} }
break; break;
#endif #endif
case PIC_TT_INT: case PIC_TT_INT:
xfprintf(file, "%d", pic_int(obj)); xfprintf(pic, file, "%d", pic_int(obj));
break; break;
case PIC_TT_EOF: case PIC_TT_EOF:
xfprintf(file, "#.(eof-object)"); xfprintf(pic, file, "#.(eof-object)");
break; break;
case PIC_TT_STRING: case PIC_TT_STRING:
if (p->mode == DISPLAY_MODE) { if (p->mode == DISPLAY_MODE) {
xfprintf(file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); xfprintf(pic, file, "%s", pic_str_cstr(pic, pic_str_ptr(obj)));
break; break;
} }
xfprintf(file, "\""); xfprintf(pic, file, "\"");
write_str(pic, pic_str_ptr(obj), file); write_str(pic, pic_str_ptr(obj), file);
xfprintf(file, "\""); xfprintf(pic, file, "\"");
break; break;
case PIC_TT_VECTOR: case PIC_TT_VECTOR:
xfprintf(file, "#("); xfprintf(pic, file, "#(");
for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
write_core(p, pic_vec_ptr(obj)->data[i]); write_core(p, pic_vec_ptr(obj)->data[i]);
if (i + 1 < pic_vec_ptr(obj)->len) { if (i + 1 < pic_vec_ptr(obj)->len) {
xfprintf(file, " "); xfprintf(pic, file, " ");
} }
} }
xfprintf(file, ")"); xfprintf(pic, file, ")");
break; break;
case PIC_TT_BLOB: case PIC_TT_BLOB:
xfprintf(file, "#u8("); xfprintf(pic, file, "#u8(");
for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { for (i = 0; i < pic_blob_ptr(obj)->len; ++i) {
xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]); xfprintf(pic, file, "%d", pic_blob_ptr(obj)->data[i]);
if (i + 1 < pic_blob_ptr(obj)->len) { if (i + 1 < pic_blob_ptr(obj)->len) {
xfprintf(file, " "); xfprintf(pic, file, " ");
} }
} }
xfprintf(file, ")"); xfprintf(pic, file, ")");
break; break;
case PIC_TT_DICT: case PIC_TT_DICT:
xfprintf(file, "#.(dictionary"); xfprintf(pic, file, "#.(dictionary");
for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) {
xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *))); xfprintf(pic, file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *)));
write_core(p, xh_val(it, pic_value)); write_core(p, xh_val(it, pic_value));
} }
xfprintf(file, ")"); xfprintf(pic, file, ")");
break; break;
case PIC_TT_ID: case PIC_TT_ID:
xfprintf(file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj))); xfprintf(pic, file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj)));
break; break;
default: default:
xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); xfprintf(pic, file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
break; break;
} }
} }
@ -377,7 +378,7 @@ pic_value
pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) pic_fwrite(pic_state *pic, pic_value obj, xFILE *file)
{ {
write(pic, obj, file); write(pic, obj, file);
xfflush(file); xfflush(pic, file);
return obj; return obj;
} }
@ -391,7 +392,7 @@ pic_value
pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file)
{ {
display(pic, obj, file); display(pic, obj, file);
xfflush(file); xfflush(pic, file);
return obj; return obj;
} }
@ -408,8 +409,8 @@ pic_printf(pic_state *pic, const char *fmt, ...)
va_end(ap); va_end(ap);
xfprintf(file, "%s", pic_str_cstr(pic, str)); xfprintf(pic, file, "%s", pic_str_cstr(pic, str));
xfflush(file); xfflush(pic, file);
} }
static pic_value static pic_value

1
piclib/picrin/base.scm
View File

@ -255,7 +255,6 @@
(export make-library (export make-library
find-library find-library
current-library current-library
library-name
library-exports library-exports
library-environment) library-environment)