Merge branch 'datum-label'

README.md

@@ -80,7 +80,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
 | --- | --- | --- |
 | 2.2 Whitespace and comments | yes | |
 | 2.3 Other notations | incomplete | #e #i #b #o #d #x |
-| 2.4 Datum labels | no | unsupported |
+| 2.4 Datum labels | yes | |
 | 3.1 Variables, syntactic keywords, and regions | | |
 | 3.2 Disjointness of types | yes | |
 | 3.3 External representations | | |

include/picrin/parse.h

@@ -11,7 +11,7 @@ extern "C" {
 
 enum {
   tEOF = 0,
-  tDATUM_COMMENT,
+  tLABEL_SET, tLABEL_REF, tDATUM_COMMENT,
   tLPAREN, tRPAREN, tLBRACKET, tRBRACKET, tDOT, tVPAREN,
   tQUOTE, tQUASIQUOTE, tUNQUOTE, tUNQUOTE_SPLICING,
   tINT, tBOOLEAN,
@@ -34,6 +34,7 @@ typedef union YYSTYPE {
 struct parser_control {
   pic_state *pic;
   YYSTYPE yylval;
+  xhash labels;
   jmp_buf jmp;
   const char *msg;
 };

include/picrin/util.h

@@ -35,6 +35,15 @@ extern "C" {
 # define UNREACHABLE() (assert(false))
 #endif
 
+#define SWAP(type,a,b)                          \
+  SWAP_HELPER__(type,GENSYM(tmp),a,b)
+#define SWAP_HELPER__(type,tmp,a,b)             \
+  do {                                          \
+    type tmp = (a);                             \
+    (a) = (b);                                  \
+    (b) = tmp;                                  \
+  } while (0)
+
 #if defined(__cplusplus)
 }
 #endif

src/macro.c

@@ -262,6 +262,10 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu
     pic_value car, v;
     xh_entry *e;
 
+    if (! pic_list_p(expr)) {
+      pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
+    }
+
     car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box);
     if (pic_sym_p(car)) {
       pic_sym tag = pic_sym(car);

src/read.c

@@ -17,6 +17,7 @@ static pic_value read(int, yyscan_t);
 
 #define pic (yyget_extra(scanner)->pic)
 #define yylval (yyget_extra(scanner)->yylval)
+#define yylabels (yyget_extra(scanner)->labels)
 #define yymsg (yyget_extra(scanner)->msg)
 #define yyjmp (yyget_extra(scanner)->jmp)
 
@@ -38,6 +39,65 @@ gettok(yyscan_t scanner)
   return tok;
 }
 
+static pic_value
+read_label_set(int i, yyscan_t scanner)
+{
+  int tok;
+  pic_value val;
+
+  switch (tok = gettok(scanner)) {
+  case tLPAREN:
+  case tLBRACKET:
+    {
+      pic_value tmp;
+
+      val = pic_cons(pic, pic_none_value(), pic_none_value());
+
+      xh_put(&yylabels, i, &val);
+
+      tmp = read(tok, scanner);
+      pic_pair_ptr(val)->car = pic_car(pic, tmp);
+      pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp);
+
+      return val;
+    }
+  case tVPAREN:
+    {
+      pic_vec *tmp;
+
+      val = pic_obj_value(pic_vec_new(pic, 0));
+
+      xh_put(&yylabels, i, &val);
+
+      tmp = pic_vec_ptr(read(tok, scanner));
+      SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
+      SWAP(size_t, tmp->len, pic_vec_ptr(val)->len);
+
+      return val;
+    }
+  default:
+    {
+      val = read(tok, scanner);
+
+      xh_put(&yylabels, i, &val);
+
+      return val;
+    }
+  }
+}
+
+static pic_value
+read_label_ref(int i, yyscan_t scanner)
+{
+  xh_entry *e;
+
+  e = xh_get(&yylabels, i);
+  if (! e) {
+    error("label of given index not defined", scanner);
+  }
+  return xh_val(e, pic_value);
+}
+
 static pic_value
 read_pair(int tOPEN, yyscan_t scanner)
 {
@@ -88,6 +148,12 @@ read_datum(int tok, yyscan_t scanner)
   pic_value val;
 
   switch (tok) {
+  case tLABEL_SET:
+    return read_label_set(yylval.i, scanner);
+
+  case tLABEL_REF:
+    return read_label_ref(yylval.i, scanner);
+
   case tSYMBOL:
     return pic_symbol_value(pic_intern(pic, yylval.buf.dat, yylval.buf.len));
 
@@ -207,12 +273,14 @@ pic_read(pic_state *pic, const char *cstr)
   pic_value val;
 
   ctrl.pic = pic;
+  xh_init_int(&ctrl.labels, sizeof(pic_value));
   yylex_init_extra(&ctrl, &scanner);
   yy_scan_string(cstr, scanner);
 
   val = read_one(scanner);
 
   yylex_destroy(scanner);
+  xh_destroy(&ctrl.labels);
 
   return val;
 }
@@ -225,12 +293,14 @@ pic_parse_file(pic_state *pic, FILE *file)
   pic_value vals;
 
   ctrl.pic = pic;
+  xh_init_int(&ctrl.labels, sizeof(pic_value));
   yylex_init_extra(&ctrl, &scanner);
   yyset_in(file, scanner);
 
   vals = read_many(scanner);
 
   yylex_destroy(scanner);
+  xh_destroy(&ctrl.labels);
 
   return vals;
 }
@@ -243,12 +313,14 @@ pic_parse_cstr(pic_state *pic, const char *cstr)
   pic_value vals;
 
   ctrl.pic = pic;
+  xh_init_int(&ctrl.labels, sizeof(pic_value));
   yylex_init_extra(&ctrl, &scanner);
   yy_scan_string(cstr, scanner);
 
   vals = read_many(scanner);
 
   yylex_destroy(scanner);
+  xh_destroy(&ctrl.labels);
 
   return vals;
 }

src/scan.l

@@ -63,6 +63,10 @@ infnan		"+inf.0"|"-inf.0"|"+nan.0"|"-nan.0"
   /* block comment */
 %x BLOCK_COMMENT
 
+  /* datum label */
+label		#{uinteger}
+%x DATUM_LABEL
+
 %%
 
 [ \t\n\r]	/* skip whitespace */
@@ -85,6 +89,19 @@ infnan		"+inf.0"|"-inf.0"|"+nan.0"|"-nan.0"
   /* skip block comment */
 }
 
+{label}		{
+  BEGIN(DATUM_LABEL);
+  yylval.i = atoi(yytext + 1);
+}
+<DATUM_LABEL>=	{
+  BEGIN(INITIAL);
+  return tLABEL_SET;
+}
+<DATUM_LABEL>#	{
+  BEGIN(INITIAL);
+  return tLABEL_REF;
+}
+
 "#;"		return tDATUM_COMMENT;
 "."		return tDOT;
 "("		return tLPAREN;