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

Merge branch 'master' of git://github.com/wasabiz/picrin into srfi1

This commit is contained in:
stibear 2014-02-11 21:53:31 +09:00
parent 47594a07e2 855702716c
commit cfdeae686c
16 changed files with 257 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
include/picrin.h
View File

@ -34,6 +34,7 @@ extern "C" {
#include <stdio.h>
#include "xhash/xhash.h"
#include "xfile/xfile.h"
#if __STDC_VERSION__ >= 201112L
# define NORETURN _Noreturn
@ -109,7 +110,7 @@ typedef struct {
struct pic_lib *lib;
jmp_buf *jmp;
const char *errmsg;
struct pic_error *err;
struct pic_heap *heap;
struct pic_object *arena[PIC_ARENA_SIZE];
@ -206,10 +207,13 @@ void pic_export(pic_state *, pic_sym);
NORETURN void pic_abort(pic_state *, const char *);
NORETURN void pic_raise(pic_state *, pic_value);
NORETURN void pic_error(pic_state *, const char *);
NORETURN void pic_errorf(pic_state *, const char *, size_t, ...);
NORETURN void pic_errorf(pic_state *, const char *, ...);
void pic_warn(pic_state *, const char *);
void pic_debug(pic_state *, pic_value);
const char *pic_errmsg(pic_state *);
pic_value pic_debug(pic_state *, pic_value);
pic_value pic_fdebug(pic_state *, pic_value, XFILE *);
#if defined(__cplusplus)
}

5
include/picrin/error.h
View File

@ -14,9 +14,10 @@ struct pic_error {
enum pic_error_kind {
PIC_ERROR_OTHER,
PIC_ERROR_FILE,
PIC_ERROR_READ
PIC_ERROR_READ,
PIC_ERROR_RAISED
} type;
char *msg;
struct pic_string *msg;
pic_value irrs;
};

8
include/picrin/port.h
View File

@ -9,9 +9,6 @@
extern "C" {
#endif
#include <stdio.h>
#include "xfile/xfile.h"
enum pic_port_flag {
PIC_PORT_IN = 1,
PIC_PORT_OUT = 2,
@ -40,6 +37,11 @@ struct pic_port *pic_stdin(pic_state *);
struct pic_port *pic_stdout(pic_state *);
struct pic_port *pic_stderr(pic_state *);
struct pic_port *pic_open_output_string(pic_state *);
struct pic_string *pic_get_output_string(pic_state *, struct pic_port *);
void pic_close_port(pic_state *pic, struct pic_port *);
#if defined(__cplusplus)
}
#endif

36
piclib/built-in.scm
View File

@ -85,26 +85,40 @@
(cons (r 'begin) (cdar clauses))
(cons (r 'cond) (cdr clauses)))))))))
(define (single? list)
(if (pair? list)
(null? (cdr list))
#f))
(define-syntax and
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(if (null? exprs)
#t
(list (r 'if) (car exprs)
(cons (r 'and) (cdr exprs))
#f))))))
(cond
((null? exprs)
#t)
((single? exprs)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(cons (r 'and) (cdr exprs))
(r 'it)))))))))
(define-syntax or
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(if (null? exprs)
#f
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(r 'it)
(cons (r 'or) (cdr exprs)))))))))
(cond
((null? exprs)
#t)
((single? exprs)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(r 'it)
(cons (r 'or) (cdr exprs))))))))))
(define-syntax quasiquote
(er-macro-transformer

4
src/codegen.c
View File

@ -292,7 +292,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
depth = lookup_var(state, sym);
if (depth == -1) {
pic_error(pic, "symbol: unbound variable");
pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym));
}
/* at this stage, lref/cref/gref are not distinguished */
return new_ref(state, depth, sym);
@ -301,7 +301,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
pic_value proc;
if (! pic_list_p(pic, obj)) {
pic_error(pic, "invalid expression given");
pic_errorf(pic, "invalid expression given: ~S", obj);
}
proc = pic_list_ref(pic, obj, 0);

127
src/error.c
View File

@ -5,28 +5,137 @@
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <stdarg.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/proc.h"
#include "picrin/port.h"
#include "picrin/error.h"
void
pic_error(pic_state *pic, const char *msg)
const char *
pic_errmsg(pic_state *pic)
{
pic->errmsg = msg;
assert(pic->err != NULL);
return pic->err->msg->str;
}
static pic_value
pic_vfformat(pic_state *pic, XFILE *file, const char *fmt, va_list ap)
{
char c;
pic_value irrs = pic_nil_value();
while ((c = *fmt++)) {
switch (c) {
default:
xfputc(c, file);
break;
case '%':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(c, file);
break;
case '%':
xfputc('%', file);
break;
case 'c':
xfprintf(file, "%c", va_arg(ap, int));
break;
case 's':
xfprintf(file, "%s", va_arg(ap, const char *));
break;
case 'd':
xfprintf(file, "%d", va_arg(ap, int));
break;
case 'p':
xfprintf(file, "%p", va_arg(ap, void *));
break;
case 'f':
xfprintf(file, "%f", va_arg(ap, double));
break;
}
break;
case '~':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(c, file);
break;
case '~':
xfputc('~', file);
break;
case '%':
xfputc('\n', file);
break;
case 'S':
irrs = pic_cons(pic, pic_fdebug(pic, va_arg(ap, pic_value), file), irrs);
break;
}
break;
}
}
exit:
return pic_reverse(pic, irrs);
}
static pic_value
pic_vformat(pic_state *pic, const char *fmt, va_list ap)
{
struct pic_port *port;
pic_value irrs;
port = pic_open_output_string(pic);
irrs = pic_vfformat(pic, port->file, fmt, ap);
irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs);
pic_close_port(pic, port);
return irrs;
}
NORETURN static void
error(pic_state *pic, struct pic_string *msg, pic_value irrs)
{
struct pic_error *e;
e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
e->type = PIC_ERROR_OTHER;
e->msg = msg;
e->irrs = irrs;
pic->err = e;
if (! pic->jmp) {
puts(msg);
puts(pic_errmsg(pic));
abort();
}
longjmp(*pic->jmp, 1);
}
void
pic_errorf(pic_state *pic, const char *msg, size_t n, ...)
pic_error(pic_state *pic, const char *msg)
{
UNUSED(n);
pic_error(pic, msg);
pic_errorf(pic, msg);
}
void
pic_errorf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value err_line;
va_start(ap, fmt);
err_line = pic_vformat(pic, fmt, ap);
va_end(ap);
error(pic, pic_str_ptr(pic_car(pic, err_line)), pic_cdr(pic, err_line));
}
void
@ -131,7 +240,7 @@ pic_error_error(pic_state *pic)
e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
e->type = PIC_ERROR_OTHER;
e->msg = pic_strdup(pic, str);
e->msg = pic_str_new_cstr(pic, str);
e->irrs = pic_list_by_array(pic, argc, argv);
pic_raise(pic, pic_obj_value(e));
@ -154,7 +263,7 @@ pic_error_error_object_message(pic_state *pic)
pic_get_args(pic, "e", &e);
return pic_obj_value(pic_str_new_cstr(pic, e->msg));
return pic_obj_value(e->msg);
}
static pic_value

1
src/file.c
View File

@ -6,7 +6,6 @@
#include "picrin.h"
#include "picrin/port.h"
#include "xfile/xfile.h"
static pic_value
generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)

10
src/gc.c
View File

@ -335,7 +335,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_ERROR: {
gc_mark(pic, ((struct pic_error *)obj)->irrs);
struct pic_error *err = (struct pic_error *)obj;
gc_mark_object(pic,(struct pic_object *)err->msg);
gc_mark(pic, err->irrs);
break;
}
case PIC_TT_STRING: {
@ -497,6 +499,11 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, (struct pic_object *)pic->rescue[i]);
}
/* error object */
if (pic->err) {
gc_mark_object(pic, (struct pic_object *)pic->err);
}
/* arena */
for (j = 0; j < pic->arena_idx; ++j) {
gc_mark_object(pic, pic->arena[j]);
@ -547,7 +554,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_ERROR: {
pic_free(pic, ((struct pic_error *)obj)->msg);
break;
}
case PIC_TT_CONT: {

2
src/init.c
View File

@ -42,7 +42,7 @@ pic_load_stdlib(pic_state *pic)
else {
/* error! */
fputs("fatal error: failure in loading built-in.scm\n", stderr);
fputs(pic->errmsg, stderr);
fputs(pic_errmsg(pic), stderr);
abort();
}

24
src/macro.c
View File

@ -368,13 +368,13 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
val = pic_cadr(pic, pic_cdr(pic, expr));
proc = pic_compile(pic, val);
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
assert(pic_proc_p(v));
@ -410,13 +410,13 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
}
proc = pic_compile(pic, val);
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
assert(pic_proc_p(v));
@ -428,15 +428,15 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
case PIC_STX_MACRO: {
if (pic_syntax(car)->senv == NULL) { /* legacy macro */
v = pic_apply(pic, pic_syntax(car)->macro, pic_cdr(pic, expr));
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
}
else {
v = pic_apply_argv(pic, pic_syntax(car)->macro, 3, expr, pic_obj_value(senv), pic_obj_value(pic_syntax(car)->senv));
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
}

18
src/pair.c
View File

@ -138,17 +138,17 @@ pic_value
pic_append(pic_state *pic, pic_value xs, pic_value ys)
{
int ai = pic_gc_arena_preserve(pic);
pic_value x;
if (pic_nil_p(xs)) {
return ys;
}
else {
xs = pic_cons(pic, pic_car(pic, xs), pic_append(pic, pic_cdr(pic, xs), ys));
}
xs = pic_reverse(pic, xs);
pic_for_each (x, xs) {
ys = pic_cons(pic, x, ys);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, xs);
return xs;
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, xs);
pic_gc_protect(pic, ys);
}
return ys;
}
pic_value

63
src/port.c
View File

@ -54,6 +54,46 @@ port_new_stdport(pic_state *pic, XFILE *file, short dir)
return pic_obj_value(port);
}
struct pic_port *
pic_open_output_string(pic_state *pic)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return port;
}
struct pic_string *
pic_get_output_string(pic_state *pic, struct pic_port *port)
{
long endpos;
char *buf;
/* get endpos */
xfflush(port->file);
endpos = xftell(port->file);
xrewind(port->file);
/* copy to buf */
buf = (char *)pic_alloc(pic, endpos);
xfread(buf, 1, endpos, port->file);
return pic_str_new(pic, buf, endpos);
}
void
pic_close_port(pic_state *pic, struct pic_port *port)
{
if (xfclose(port->file) == EOF) {
pic_error(pic, "close-port: failure");
}
port->status = PIC_PORT_CLOSE;
}
static pic_value
pic_port_input_port_p(pic_state *pic)
{
@ -188,10 +228,7 @@ pic_port_close_port(pic_state *pic)
pic_get_args(pic, "p", &port);
if (xfclose(port->file) == EOF) {
pic_error(pic, "close-port: failure");
}
port->status = PIC_PORT_CLOSE;
pic_close_port(pic, port);
return pic_none_value();
}
@ -251,10 +288,7 @@ pic_port_open_output_string(pic_state *pic)
pic_get_args(pic, "");
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
port = pic_open_output_string(pic);
return pic_obj_value(port);
}
@ -263,23 +297,12 @@ static pic_value
pic_port_get_output_string(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);;
long endpos;
char *buf;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string");
/* get endpos */
xfflush(port->file);
endpos = xftell(port->file);
xrewind(port->file);
/* copy to buf */
buf = (char *)pic_alloc(pic, endpos);
xfread(buf, 1, endpos, port->file);
return pic_obj_value(pic_str_new(pic, buf, endpos));
return pic_obj_value(pic_get_output_string(pic, port));
}
static pic_value

2
src/state.c
View File

@ -70,7 +70,7 @@ pic_open(int argc, char *argv[], char **envp)
/* error handling */
pic->jmp = NULL;
pic->errmsg = NULL;
pic->err = NULL;
/* GC arena */
pic->arena_idx = 0;

17
src/vm.c
View File

@ -539,8 +539,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
#if DEBUG
pic_debug(pic, x);
#endif
pic->errmsg = "invalid application";
goto L_RAISE;
pic_error(pic, "invalid application");
}
proc = pic_proc_ptr(x);
@ -586,8 +585,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
if (ci->argc != proc->u.irep->argc) {
if (! (proc->u.irep->varg && ci->argc >= proc->u.irep->argc)) {
pic->errmsg = "wrong number of arguments";
goto L_RAISE;
pic_errorf(pic, "wrong number of arguments (%d for %d%s)", ci->argc - 1, proc->u.irep->argc - 1, (proc->u.irep->varg ? "+" : ""));
}
}
/* prepare rest args */
@ -643,7 +641,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_value v;
pic_callinfo *ci;
if (pic->errmsg) {
if (pic->err) {
L_RAISE:
goto L_STOP;
@ -726,8 +724,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
PUSH(pic_float_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
pic_error(pic, #op " got non-number operands"); \
} \
NEXT; \
}
@ -747,7 +744,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
PUSH(pic_float_value(-pic_float(n)));
}
else {
pic->errmsg = "unary - got a non-number operand";
pic_error(pic, "unary - got a non-number operand");
}
NEXT;
}
@ -770,7 +767,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
pic_error(pic, #op " got non-number operands"); \
goto L_RAISE; \
} \
NEXT; \
@ -787,7 +784,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
val = POP();
pic->jmp = prev_jmp;
if (pic->errmsg) {
if (pic->err) {
return pic_undef_value();
}

13
src/write.c
View File

@ -154,11 +154,18 @@ write(pic_state *pic, pic_value obj, XFILE *file)
}
}
void
pic_value
pic_debug(pic_state *pic, pic_value obj)
{
write(pic, obj, xstdout);
xfflush(xstdout);
return pic_fdebug(pic, obj, xstdout);
}
pic_value
pic_fdebug(pic_state *pic, pic_value obj, XFILE *file)
{
write(pic, obj, file);
xfflush(file);
return obj;
}
static pic_value

12
tools/main.c
View File

@ -124,14 +124,14 @@ repl(pic_state *pic)
/* eval */
proc = pic_compile(pic, v);
if (proc == NULL) {
printf("compilation error: %s\n", pic->errmsg);
pic->errmsg = NULL;
printf("compilation error: %s\n", pic_errmsg(pic));
pic->err = NULL;
goto next;
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic_undef_p(v)) {
printf("runtime error: %s\n", pic->errmsg);
pic->errmsg = NULL;
printf("runtime error: %s\n", pic_errmsg(pic));
pic->err = NULL;
goto next;
}
@ -185,14 +185,14 @@ exec_file(pic_state *pic, const char *fname)
proc = pic_compile(pic, v);
if (proc == NULL) {
fputs(pic->errmsg, stderr);
fputs(pic_errmsg(pic), stderr);
fprintf(stderr, "fatal error: %s compilation failure\n", fname);
goto abort;
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic_undef_p(v)) {
fputs(pic->errmsg, stderr);
fputs(pic_errmsg(pic), stderr);
fprintf(stderr, "fatal error: %s evaluation failure\n", fname);
goto abort;
}