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

include/picrin.h

@@ -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)
 }

include/picrin/error.h

@@ -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;
 };
 

include/picrin/port.h

@@ -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

piclib/built-in.scm

@@ -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)
+         (cond
-             #t
+          ((null? exprs)
-             (list (r 'if) (car exprs)
+           #t)
-                   (cons (r 'and) (cdr exprs))
+          ((single? exprs)
-                   #f))))))
+           (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)
+         (cond
-             #f
+          ((null? exprs)
-             (list (r 'let) (list (list (r 'it) (car exprs)))
+           #t)
-                   (list (r 'if) (r 'it)
+          ((single? exprs)
-                         (r 'it)
+           (car exprs))
-                         (cons (r 'or) (cdr 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

src/codegen.c

@@ -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);

src/error.c

@@ -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
+const char *
-pic_error(pic_state *pic, const char *msg)
+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_errorf(pic, msg);
-  pic_error(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

src/file.c

@@ -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)

src/gc.c

@@ -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: {

src/init.c

@@ -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();
   }
 

src/macro.c

@@ -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) {
+	if (pic->err) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
+	  printf("macroexpand error: %s\n", pic_errmsg(pic));
 	  abort();
 	}
 	v = pic_apply(pic, proc, pic_nil_value());
-	if (pic->errmsg) {
+	if (pic->err) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
+	  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) {
+	if (pic->err) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
+	  printf("macroexpand error: %s\n", pic_errmsg(pic));
 	  abort();
 	}
 	v = pic_apply(pic, proc, pic_nil_value());
-	if (pic->errmsg) {
+	if (pic->err) {
-	  printf("macroexpand error: %s\n", pic->errmsg);
+	  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) {
+	  if (pic->err) {
-	    printf("macroexpand error: %s\n", pic->errmsg);
+	    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) {
+	  if (pic->err) {
-	    printf("macroexpand error: %s\n", pic->errmsg);
+	    printf("macroexpand error: %s\n", pic_errmsg(pic));
 	    abort();
 	  }
 	}

src/pair.c

@@ -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)) {
+  xs = pic_reverse(pic, xs);
-    return ys;
+  pic_for_each (x, xs) {
-  }
+    ys = pic_cons(pic, x, ys);
-  else {
-    xs = pic_cons(pic, pic_car(pic, xs), pic_append(pic, pic_cdr(pic, xs), ys));
-  }
 
-  pic_gc_arena_restore(pic, ai);
+    pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, xs);
+    pic_gc_protect(pic, xs);
-  return xs;
+    pic_gc_protect(pic, ys);
+  }
+  return ys;
 }
 
 pic_value

src/port.c

@@ -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_close_port(pic, port);
-    pic_error(pic, "close-port: failure");
-  }
-  port->status = PIC_PORT_CLOSE;
 
   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 = pic_open_output_string(pic);
-  port->file = xmopen();
-  port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
-  port->status = PIC_PORT_OPEN;
 
   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 */
+  return pic_obj_value(pic_get_output_string(pic, port));
-  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));
 }
 
 static pic_value

src/state.c

@@ -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;

src/vm.c

@@ -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";
+	pic_error(pic, "invalid application");
-	goto L_RAISE;
       }
       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";
+            pic_errorf(pic, "wrong number of arguments (%d for %d%s)", ci->argc - 1, proc->u.irep->argc - 1, (proc->u.irep->varg ? "+" : ""));
-	    goto L_RAISE;
 	  }
 	}
 	/* 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";		\
+	pic_error(pic, #op " got non-number operands");		\
-	goto L_RAISE;						\
       }								\
       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();
       }
 

src/write.c

@@ -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);
+  return pic_fdebug(pic, obj, xstdout);
-  xfflush(xstdout);
+}
+
+pic_value
+pic_fdebug(pic_state *pic, pic_value obj, XFILE *file)
+{
+  write(pic, obj, file);
+  xfflush(file);
+  return obj;
 }
 
 static pic_value

tools/main.c

@@ -124,14 +124,14 @@ repl(pic_state *pic)
       /* eval */
       proc = pic_compile(pic, v);
       if (proc == NULL) {
-	printf("compilation error: %s\n", pic->errmsg);
+	printf("compilation error: %s\n", pic_errmsg(pic));
-	pic->errmsg = NULL;
+	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);
+	printf("runtime error: %s\n", pic_errmsg(pic));
-	pic->errmsg = NULL;
+	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;
     }