Merge branch 'dictionary'

docs/lang.rst

@@ -55,6 +55,37 @@ Libraries
 
   Delimited control operators.
 
+- ``(picrin dictionary)``
+
+  Symbol to Object table. Internally it is implemented on hash-table.
+
+  Note that dictionary is not a weak map; if you are going to make a highly memory-consuming program with dictionaries, you should know that dictionaries keep their bound objects and never let them free until you explicitly deletes bindings.
+
+  - ``(dictionary)``
+
+    Returns a newly allocated empty dictionary. In the future, it is planned to extend this function to take optional arguments for initial key/values.
+
+  - ``(dictionary? obj)``
+
+    Returns ``#t`` if obj is a dictionary.
+
+  - ``(dictionary-ref dict key)``
+
+    Look up dictionary dict for a value associated with symbol key. If no object is associated with key, it will raise an error.
+
+  - ``(dictionary-set! dict key obj)``
+
+    If there is no value already associated with key, this function newly creates a binding of key with obj. Otherwise, updates the existing binding with given obj.
+
+  - ``(dictionary-delete dict key)``
+
+    Deletes the binding associated with key from dict. If no binding on dict is associated with key, an error will be raised.
+
+
+  - ``(dictionary-size dict)``
+
+    Returns the number of registered elements in dict.
+
 - ``(picrin user)``
 
   When you start the REPL, you are dropped into here.

extlib/xhash

@@ -1 +1 @@
-Subproject commit 47a31fdbf88ea61f060b7cb45203b3a2f0149e9f
+Subproject commit ddc2ea288b37b3f5de37024ff2648d11aa18811a

include/picrin/dict.h

@@ -0,0 +1,24 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#ifndef PICRIN_DICT_H__
+#define PICRIN_DICT_H__
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+struct pic_dict {
+  PIC_OBJECT_HEADER
+  xhash hash;
+};
+
+#define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT)
+#define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v))
+
+#if defined(__cplusplus)
+}
+#endif
+
+#endif

include/picrin/value.h

@@ -116,7 +116,8 @@ enum pic_tt {
   PIC_TT_VAR,
   PIC_TT_IREP,
   PIC_TT_DATA,
-  PIC_TT_BOX
+  PIC_TT_BOX,
+  PIC_TT_DICT
 };
 
 #define PIC_OBJECT_HEADER			\
@@ -146,7 +147,8 @@ typedef struct pic_blob pic_blob;
 #define pic_sym(v) ((v).u.sym)
 #define pic_char(v) ((v).u.c)
 
-#define pic_obj_ptr(o) ((struct pic_object *)pic_ptr(o))
+#define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP)
+#define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v))
 
 #define pic_nil_p(v) (pic_vtype(v) == PIC_VTYPE_NIL)
 #define pic_true_p(v) (pic_vtype(v) == PIC_VTYPE_TRUE)
@@ -269,6 +271,8 @@ pic_type_repr(enum pic_tt tt)
     return "data";
   case PIC_TT_BOX:
     return "box";
+  case PIC_TT_DICT:
+    return "dict";
   }
   UNREACHABLE();
 }

src/codegen.c

@@ -825,6 +825,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
   case PIC_TT_IREP:
   case PIC_TT_DATA:
   case PIC_TT_BOX:
+  case PIC_TT_DICT:
     pic_errorf(pic, "invalid expression given: ~s", obj);
   }
   UNREACHABLE();

src/dict.c

@@ -0,0 +1,100 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/dict.h"
+
+static pic_value
+pic_dict_dict(pic_state *pic)
+{
+  struct pic_dict *dict;
+
+  pic_get_args(pic, "");
+
+  dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
+
+  xh_init_int(&dict->hash, sizeof(pic_value));
+
+  return pic_obj_value(dict);
+}
+
+static pic_value
+pic_dict_dict_p(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+
+  return pic_bool_value(pic_dict_p(obj));
+}
+
+static pic_value
+pic_dict_dict_ref(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_sym key;
+  xh_entry *e;
+
+  pic_get_args(pic, "dm", &dict, &key);
+
+  e = xh_get_int(&dict->hash, key);
+  if (! e) {
+    pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key));
+  }
+  return xh_val(e, pic_value);
+}
+
+static pic_value
+pic_dict_dict_set(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_sym key;
+  pic_value val;
+
+  pic_get_args(pic, "dmo", &dict, &key, &val);
+
+  xh_put_int(&dict->hash, key, &val);
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_dict_dict_del(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_sym key;
+
+  pic_get_args(pic, "dm", &dict, &key);
+
+  if (xh_get_int(&dict->hash, key) == NULL) {
+    pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key));
+  }
+
+  xh_del_int(&dict->hash, key);
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_dict_dict_size(pic_state *pic)
+{
+  struct pic_dict *dict;
+
+  pic_get_args(pic, "d", &dict);
+
+  return pic_int_value(dict->hash.count);
+}
+
+void
+pic_init_dict(pic_state *pic)
+{
+  pic_deflibrary ("(picrin dictionary)") {
+    pic_defun(pic, "dictionary", pic_dict_dict);
+    pic_defun(pic, "dictionary?", pic_dict_dict_p);
+    pic_defun(pic, "dictionary-ref", pic_dict_dict_ref);
+    pic_defun(pic, "dictionary-set!", pic_dict_dict_set);
+    pic_defun(pic, "dictionary-delete", pic_dict_dict_del);
+    pic_defun(pic, "dictionary-size", pic_dict_dict_size);
+  }
+}

src/gc.c

@@ -20,6 +20,7 @@
 #include "picrin/var.h"
 #include "picrin/data.h"
 #include "picrin/box.h"
+#include "picrin/dict.h"
 
 #if GC_DEBUG
 # include <string.h>
@@ -504,6 +505,16 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     gc_mark(pic, box->value);
     break;
   }
+  case PIC_TT_DICT: {
+    struct pic_dict *dict = (struct pic_dict *)obj;
+    xh_iter it;
+
+    xh_begin(&it, &dict->hash);
+    while (xh_next(&it)) {
+      gc_mark(pic, xh_val(it.e, pic_value));
+    }
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:
@@ -657,6 +668,11 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_BOX: {
     break;
   }
+  case PIC_TT_DICT: {
+    struct pic_dict *dict = (struct pic_dict *)obj;
+    xh_destroy(&dict->hash);
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:

src/init.c

@@ -29,6 +29,7 @@ void pic_init_macro(pic_state *);
 void pic_init_var(pic_state *);
 void pic_init_load(pic_state *);
 void pic_init_write(pic_state *);
+void pic_init_dict(pic_state *);
 
 void pic_load_piclib(pic_state *);
 
@@ -93,6 +94,7 @@ pic_init_core(pic_state *pic)
     pic_init_var(pic); DONE;
     pic_init_load(pic); DONE;
     pic_init_write(pic); DONE;
+    pic_init_dict(pic); DONE;
 
     pic_load_piclib(pic); DONE;
 

src/macro.c

@@ -569,6 +569,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
   case PIC_TT_IREP:
   case PIC_TT_DATA:
   case PIC_TT_BOX:
+  case PIC_TT_DICT:
     pic_errorf(pic, "unexpected value type: ~s", expr);
   }
   UNREACHABLE();

src/vm.c

@@ -19,6 +19,7 @@
 #include "picrin/lib.h"
 #include "picrin/macro.h"
 #include "picrin/error.h"
+#include "picrin/dict.h"
 
 #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)])
 
@@ -49,6 +50,7 @@ pic_get_proc(pic_state *pic)
  *  c   char
  *  l   lambda object
  *  p   port object
+ *  d   dictionary object
  *
  *  |  optional operator
  *  *  variable length operator
@@ -327,6 +329,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
       }
       break;
     }
+    case 'd': {
+      struct pic_dict **d;
+      pic_value v;
+
+      d = va_arg(ap, struct pic_dict **);
+      if (i < argc) {
+        v = GET_OPERAND(pic,i);
+        if (pic_dict_p(v)) {
+          *d = pic_dict_ptr(v);
+        }
+        else {
+          pic_error(pic, "pic_get_args, expected dictionary");
+        }
+        i++;
+      }
+      break;
+    }
     default:
       pic_error(pic, "pic_get_args: invalid argument specifier given");
     }

src/write.c

@@ -338,6 +338,9 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_BOX:
     xfprintf(file, "#<box %p>", pic_ptr(obj));
     break;
+  case PIC_TT_DICT:
+    xfprintf(file, "#<dict %p>", pic_ptr(obj));
+    break;
   }
 }