add pic_serialize and pic_deserialize

lib/Makefile

@@ -8,19 +8,18 @@ LIBPICRIN_SRCS = \
 	dict.c\
 	error.c\
 	gc.c\
-	load.c\
 	number.c\
 	pair.c\
 	port.c\
 	proc.c\
 	record.c\
+	serialize.c\
 	state.c\
 	string.c\
 	symbol.c\
 	var.c\
 	vector.c\
 	weak.c\
-	ext/serialize.c\
 	ext/eval.c\
 	ext/read.c\
 	ext/write.c\

lib/ext/main.c

@@ -37,6 +37,8 @@ main(int argc, char *argv[])
       }
     } else if (argc >= 3 && strcmp(argv[1], "-c") == 0) { /* compile */
       const char *name = argv[2];
+      const unsigned char *bin;
+      int len, i;
       if (argc == 3) {
         port = pic_stdin(pic);
       } else {
@@ -47,7 +49,20 @@ main(int argc, char *argv[])
         }
         port = pic_fopen(pic, file, "r");
       }
-      pic_serialize(pic, name, pic_assemble(pic, pic_funcall(pic, "compile", 1, pic_funcall(pic, "read", 1, port))));
+      bin = pic_blob(pic, pic_serialize(pic, pic_funcall(pic, "compile", 1, pic_funcall(pic, "read", 1, port))), &len);
+      printf("const unsigned char %s[] = {\n", name);
+      for (i = 0; i < len; ++i) {
+        printf("0x%02x,", bin[i]);
+        if ((i + 1) % 12 == 0) {
+          putchar('\n');
+        } else {
+          putchar(' ');
+        }
+      }
+      if (len != 0) {
+        puts("");
+      }
+      printf("};\n");
     } else {
       fprintf(stderr, "usage: mini-picrin [-c] [file]\n");
       exit(1);

lib/ext/serialize.c

@@ -1,180 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/extra.h"
-#include "../object.h"
-#include "../state.h"
-
-static size_t offset = 0;
-
-static void
-dump1(pic_state *pic, unsigned char c)
-{
-  printf("0x%02x,", c);
-  if (++offset == 12) {
-    puts("");
-    offset = 0;
-  } else {
-    putchar(' ');
-  }
-}
-
-static void
-dump4(pic_state *pic, unsigned long n)
-{
-  assert(sizeof(long) * CHAR_BIT <= 32 || n < (1ul << 32));
-
-  dump1(pic, (n & 0xff));
-  dump1(pic, (n & 0xff00) >> 8);
-  dump1(pic, (n & 0xff0000) >> 16);
-  dump1(pic, (n & 0xff000000) >> 24);
-}
-
-static void
-dump_obj(pic_state *pic, pic_value obj)
-{
-  if (pic_int_p(pic, obj)) {
-    dump1(pic, 0x00);
-    dump4(pic, pic_int(pic, obj));
-  } else if (pic_str_p(pic, obj)) {
-    int len, i;
-    const char *str = pic_str(pic, obj, &len);
-    dump1(pic, 0x01);
-    dump4(pic, len);
-    for (i = 0; i < len; ++i) {
-      dump1(pic, str[i]);
-    }
-    dump1(pic, 0);
-  } else if (pic_sym_p(pic, obj)) {
-    int len, i;
-    const char *str = pic_str(pic, pic_sym_name(pic, obj), &len);
-    dump1(pic, 0x02);
-    dump4(pic, len);
-    for (i = 0; i < len; ++i) {
-      dump1(pic, str[i]);
-    }
-    dump1(pic, 0);
-  } else {
-    pic_error(pic, "dump: unsupported object", 1, obj);
-  }
-}
-
-#define IREP_FLAGS_MASK (IREP_VARG)
-
-static void
-dump_irep(pic_state *pic, struct irep *irep)
-{
-  size_t i;
-  dump1(pic, irep->argc);
-  dump1(pic, irep->flags & IREP_FLAGS_MASK);
-  dump1(pic, irep->frame_size);
-  dump1(pic, irep->irepc);
-  dump1(pic, irep->objc);
-  dump4(pic, irep->codec);
-  for (i = 0; i < irep->objc; ++i) {
-    dump_obj(pic, irep->obj[i]);
-  }
-  for (i = 0; i < irep->codec; ++i) {
-    dump1(pic, irep->code[i]);
-  }
-  for (i = 0; i < irep->irepc; ++i) {
-    dump_irep(pic, irep->irep[i]);
-  }
-}
-
-void
-pic_serialize(pic_state *pic, const char *name, pic_value irep)
-{
-  offset = 0;
-  printf("const unsigned char %s[] = {\n", name);
-  dump_irep(pic, irep_ptr(pic, irep));
-  if (offset != 0) puts("");
-  printf("};\n");
-}
-
-const unsigned char *bin;
-
-static unsigned char
-load1(pic_state *pic)
-{
-  return *bin++;
-}
-
-static unsigned long
-load4(pic_state *pic)
-{
-  unsigned long x = bin[0] + (bin[1] << 8) + (bin[2] << 16) + (bin[3] << 24);
-  bin += 4;
-  return x;
-}
-
-static pic_value
-load_obj(pic_state *pic)
-{
-  int type, len;
-  pic_value obj;
-  type = load1(pic);
-  switch (type) {
-  case 0x00:
-    return pic_int_value(pic, load4(pic));
-  case 0x01:
-    len = load4(pic);
-    obj = pic_str_value(pic, bin, -len);
-    bin += len + 1;
-    return obj;
-  case 0x02:
-    len = load4(pic);
-    obj = pic_str_value(pic, bin, -len);
-    obj = pic_intern(pic, obj);
-    bin += len + 1;
-    return obj;
-  default:
-    pic_error(pic, "load: unsupported object", 1, pic_int_value(pic, type));
-  }
-}
-
-static struct irep *
-load_irep(pic_state *pic)
-{
-  unsigned char argc, flags, frame_size, irepc, objc;
-  size_t codec, i;
-  pic_value *obj;
-  const unsigned char *code;
-  struct irep **irep, *ir;
-  argc = load1(pic);
-  flags = load1(pic) | IREP_CODE_STATIC;
-  frame_size = load1(pic);
-  irepc = load1(pic);
-  objc = load1(pic);
-  codec = load4(pic);
-  obj = pic_malloc(pic, sizeof(pic_value) * objc);
-  for (i = 0; i < objc; ++i) {
-    obj[i] = load_obj(pic);
-  }
-  code = bin;
-  bin += codec;
-  irep = pic_malloc(pic, sizeof(struct irep *) * irepc);
-  for (i = 0; i < irepc; ++i) {
-    irep[i] = load_irep(pic);
-  }
-  ir = (struct irep *) pic_obj_alloc(pic, PIC_TYPE_IREP);
-  ir->argc = argc;
-  ir->flags = flags;
-  ir->frame_size = frame_size;
-  ir->irepc = irepc;
-  ir->objc = objc;
-  ir->codec = codec;
-  ir->obj = obj;
-  ir->code = code;
-  ir->irep = irep;
-  return ir;
-}
-
-pic_value
-pic_deserialize(pic_state *pic, const unsigned char *str)
-{
-  bin = str;
-  return obj_value(pic, load_irep(pic));
-}

lib/include/picrin.h

@@ -129,6 +129,9 @@ char pic_char(pic_state *, pic_value c);
 const char *pic_str(pic_state *, pic_value str, int *len);
 unsigned char *pic_blob(pic_state *, pic_value blob, int *len);
 void *pic_data(pic_state *, pic_value data);
+/* serialization */
+pic_value pic_serialize(pic_state *pic, pic_value obj);
+pic_value pic_deserialize(pic_state *pic, pic_value blob);
 
 
 /*

lib/include/picrin/extra.h

@@ -17,13 +17,6 @@ void *pic_default_allocf(void *, void *, size_t);
 pic_value pic_fopen(pic_state *, FILE *, const char *mode);
 #endif
 
-pic_value pic_load(pic_state *, pic_value irep); /* TODO */
-void pic_load_native(pic_state *pic, const char *); /* TODO */
-pic_value pic_assemble(pic_state *pic, pic_value as);
-pic_value pic_execute(pic_state *pic, pic_value irep);
-void pic_serialize(pic_state *pic, const char *name, pic_value irep);
-pic_value pic_deserialize(pic_state *pic, const unsigned char *bin);
-
 /* for debug */
 
 #if PIC_USE_WRITE

lib/load.c

@@ -1,46 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/extra.h"
-#include "../object.h"
-
-pic_value
-pic_load(pic_state *pic, pic_value expr)
-{
-  return pic_execute(pic, pic_assemble(pic, expr));
-}
-
-void
-pic_load_native(pic_state *pic, const char *str)
-{
-  pic_value e, port = pic_fmemopen(pic, str, strlen(str), "r");
-
-  pic_try {
-    size_t ai = pic_enter(pic);
-    pic_load(pic, pic_funcall(pic, "read", 1, port));
-    pic_leave(pic, ai);
-  }
-  pic_catch(e) {
-    pic_fclose(pic, port);
-    pic_raise(pic, e);
-  }
-  pic_fclose(pic, port);
-}
-
-static pic_value
-pic_load_load(pic_state *pic)
-{
-  pic_value program;
-
-  pic_get_args(pic, "o", &program);
-
-  return pic_load(pic, program);
-}
-
-void
-pic_init_load(pic_state *pic)
-{
-  pic_defun(pic, "load", pic_load_load);
-}

lib/proc.c

@@ -158,23 +158,6 @@ assemble(pic_state *pic, pic_value as)
   return ir;
 }
 
-pic_value
-pic_assemble(pic_state *pic, pic_value as)
-{
-  return obj_value(pic, assemble(pic, as));
-}
-
-pic_value
-pic_execute(pic_state *pic, pic_value irep)
-{
-  struct proc *proc;
-
-  proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
-  proc->u.irep = irep_ptr(pic, irep);
-  proc->env = NULL;
-  return pic_apply(pic, obj_value(pic, proc), 0, NULL);
-}
-
 struct frame *
 pic_make_frame_unsafe(pic_state *pic, int n)
 {
@@ -723,6 +706,23 @@ pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *args)
   return pic_invalid_value(pic);
 }
 
+static pic_value
+pic_proc_make_procedure(pic_state *pic)
+{
+  pic_value as;
+  struct irep *irep;
+  struct proc *proc;
+
+  pic_get_args(pic, "o", &as);
+
+  irep = assemble(pic, as);
+
+  proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
+  proc->u.irep = irep;
+  proc->env = NULL;
+  return obj_value(pic, proc);
+}
+
 static pic_value
 pic_proc_proc_p(pic_state *pic)
 {
@@ -761,6 +761,7 @@ pic_proc_apply(pic_state *pic)
 void
 pic_init_proc(pic_state *pic)
 {
+  pic_defun(pic, "make-procedure", pic_proc_make_procedure);
   pic_defun(pic, "procedure?", pic_proc_proc_p);
   pic_defun(pic, "apply", pic_proc_apply);
 }

lib/serialize.c

@@ -0,0 +1,202 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "object.h"
+
+static void
+dump1(pic_state *pic, unsigned char c, pic_value port)
+{
+  pic_fputc(pic, c, port);
+}
+
+static void
+dump4(pic_state *pic, unsigned long n, pic_value port)
+{
+  assert(sizeof(long) * CHAR_BIT <= 32 || n < (1ul << 32));
+
+  dump1(pic, (n & 0xff), port);
+  dump1(pic, (n & 0xff00) >> 8, port);
+  dump1(pic, (n & 0xff0000) >> 16, port);
+  dump1(pic, (n & 0xff000000) >> 24, port);
+}
+
+static void dump_obj(pic_state *pic, pic_value obj, pic_value port);
+
+#define IREP_FLAGS_MASK (IREP_VARG)
+
+static void
+dump_irep(pic_state *pic, struct irep *irep, pic_value port)
+{
+  size_t i;
+  dump1(pic, irep->argc, port);
+  dump1(pic, irep->flags & IREP_FLAGS_MASK, port);
+  dump1(pic, irep->frame_size, port);
+  dump1(pic, irep->irepc, port);
+  dump1(pic, irep->objc, port);
+  dump4(pic, irep->codec, port);
+  for (i = 0; i < irep->objc; ++i) {
+    dump_obj(pic, irep->obj[i], port);
+  }
+  for (i = 0; i < irep->codec; ++i) {
+    dump1(pic, irep->code[i], port);
+  }
+  for (i = 0; i < irep->irepc; ++i) {
+    dump_irep(pic, irep->irep[i], port);
+  }
+}
+
+static void
+dump_obj(pic_state *pic, pic_value obj, pic_value port)
+{
+  if (pic_int_p(pic, obj)) {
+    dump1(pic, 0x00, port);
+    dump4(pic, pic_int(pic, obj), port);
+  } else if (pic_str_p(pic, obj)) {
+    int len, i;
+    const char *str = pic_str(pic, obj, &len);
+    dump1(pic, 0x01, port);
+    dump4(pic, len, port);
+    for (i = 0; i < len; ++i) {
+      dump1(pic, str[i], port);
+    }
+    dump1(pic, 0, port);
+  } else if (pic_sym_p(pic, obj)) {
+    int len, i;
+    const char *str = pic_str(pic, pic_sym_name(pic, obj), &len);
+    dump1(pic, 0x02, port);
+    dump4(pic, len, port);
+    for (i = 0; i < len; ++i) {
+      dump1(pic, str[i], port);
+    }
+    dump1(pic, 0, port);
+  } else if (pic_proc_p(pic, obj)) {
+    if (pic_proc_func_p(pic, obj)) {
+      pic_error(pic, "dump: c function procedure serialization unsupported", 1, obj);
+    }
+    if (proc_ptr(pic, obj)->env) {
+      pic_error(pic, "dump: local procedure serialization unsupported", 1, obj);
+    }
+    dump1(pic, 0x03, port);
+    dump_irep(pic, proc_ptr(pic, obj)->u.irep, port);
+  } else {
+    pic_error(pic, "dump: unsupported object", 1, obj);
+  }
+}
+
+pic_value
+pic_serialize(pic_state *pic, pic_value obj)
+{
+  pic_value port = pic_funcall(pic, "open-output-bytevector", 0);
+  pic_value blob;
+  dump_obj(pic, obj, port);
+  blob = pic_funcall(pic, "get-output-bytevector", 1, port);
+  pic_fclose(pic, port);
+  return blob;
+}
+
+static unsigned char
+load1(pic_state *pic, pic_value port)
+{
+  return pic_fgetc(pic, port);
+}
+
+static unsigned long
+load4(pic_state *pic, pic_value port)
+{
+  unsigned long x = load1(pic, port);
+  x += load1(pic, port) << 8;
+  x += load1(pic, port) << 16;
+  x += load1(pic, port) << 24;
+  return x;
+}
+
+static pic_value load_obj(pic_state *pic, pic_value port);
+
+static struct irep *
+load_irep(pic_state *pic, pic_value port)
+{
+  unsigned char argc, flags, frame_size, irepc, objc;
+  size_t codec, i;
+  pic_value *obj;
+  unsigned char *code;
+  struct irep **irep, *ir;
+  size_t ai = pic_enter(pic);
+
+  argc = load1(pic, port);
+  flags = load1(pic, port);
+  frame_size = load1(pic, port);
+  irepc = load1(pic, port);
+  objc = load1(pic, port);
+  codec = load4(pic, port);
+  obj = pic_malloc(pic, sizeof(pic_value) * objc);
+  for (i = 0; i < objc; ++i) {
+    obj[i] = load_obj(pic, port);
+  }
+  code = pic_malloc(pic, codec); /* TODO */
+  pic_fread(pic, code, codec, 1, port);
+  irep = pic_malloc(pic, sizeof(struct irep *) * irepc);
+  for (i = 0; i < irepc; ++i) {
+    irep[i] = load_irep(pic, port);
+  }
+  ir = (struct irep *) pic_obj_alloc(pic, PIC_TYPE_IREP);
+  ir->argc = argc;
+  ir->flags = flags;
+  ir->frame_size = frame_size;
+  ir->irepc = irepc;
+  ir->objc = objc;
+  ir->codec = codec;
+  ir->obj = obj;
+  ir->code = code;
+  ir->irep = irep;
+  pic_leave(pic, ai);
+  pic_protect(pic, obj_value(pic, ir));
+  return ir;
+}
+
+static pic_value
+load_obj(pic_state *pic, pic_value port)
+{
+  int type, len;
+  pic_value obj;
+  char *buf;
+  struct irep *irep;
+  struct proc *proc;
+  type = load1(pic, port);
+  switch (type) {
+  case 0x00:
+    return pic_int_value(pic, load4(pic, port));
+  case 0x01:
+    len = load4(pic, port);
+    buf = pic_malloc(pic, len + 1); /* TODO */
+    pic_fread(pic, buf, len + 1, 1, port);
+    obj = pic_str_value(pic, buf, len);
+    pic_free(pic, buf);
+    return obj;
+  case 0x02:
+    len = load4(pic, port);
+    buf = pic_malloc(pic, len + 1); /* TODO */
+    pic_fread(pic, buf, len + 1, 1, port);
+    obj = pic_intern_str(pic, buf, len);
+    pic_free(pic, buf);
+    return obj;
+  case 0x03:
+    irep = load_irep(pic, port);
+    proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
+    proc->u.irep = irep;
+    proc->env = NULL;
+    return obj_value(pic, proc);
+  default:
+    pic_error(pic, "load: unsupported object", 1, pic_int_value(pic, type));
+  }
+}
+
+pic_value
+pic_deserialize(pic_state *pic, pic_value blob)
+{
+  pic_value port = pic_funcall(pic, "open-input-bytevector", 1, blob);
+  pic_value obj = load_obj(pic, port);
+  pic_fclose(pic, port);
+  return obj;
+}

lib/state.c

@@ -108,7 +108,6 @@ void pic_init_read(pic_state *);
 void pic_init_dict(pic_state *);
 void pic_init_record(pic_state *);
 void pic_init_weak(pic_state *);
-void pic_init_load(pic_state *);
 void pic_init_file(pic_state *);
 void pic_init_state(pic_state *);
 void pic_init_eval(pic_state *);
@@ -136,7 +135,6 @@ pic_init_core(pic_state *pic)
   pic_init_dict(pic); DONE;
   pic_init_record(pic); DONE;
   pic_init_weak(pic); DONE;
-  pic_init_load(pic); DONE;
   pic_init_state(pic); DONE;
 
 #if PIC_USE_READ

piclib/eval.scm

@@ -886,11 +886,11 @@
               (car (reps))))))
 
       (lambda (e . env)
-        (codegen (transform (normalize (apply expand e env)))))))
+        (make-procedure (codegen (transform (normalize (apply expand e env))))))))
 
 
   ;; eval
 
   (define (eval expr . env)
-    (load (apply compile expr env))))
+    ((apply compile expr env))))
 

tools/mkeval.scm

@@ -3,7 +3,8 @@
  `("#include \"picrin.h\"\n"
    "#include \"picrin/extra.h\"\n"
    "\n"
-   "#if PIC_USE_EVAL\n"))
+   "#if PIC_USE_EVAL\n"
+   "static "))
 
 (let loop ()
   (let ((c (read-u8)))
@@ -19,6 +20,6 @@
    "pic_init_eval(pic_state *PIC_UNUSED(pic))\n"
    "{\n"
    "#if PIC_USE_EVAL\n"
-   "  pic_execute(pic, pic_deserialize(pic, eval_rom));\n"
+   "  pic_call(pic, pic_deserialize(pic, pic_blob_value(pic, eval_rom, sizeof eval_rom)), 0);\n"
    "#endif\n"
    "}\n"))