Merge remote-tracking branch 'upstream/master' into syntax-rules

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 | | |
@@ -122,7 +122,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
 | 6.2.4 Implementation extensions | yes | |
 | 6.2.5 Syntax of numerical constants | yes | |
 | 6.2.6 Numerical operations | yes | `denominator`, `numerator`, and `rationalize` are not supported for now. Also, picrin does not provide complex library procedures. |
-| 6.2.7 Numerical input and output | no | |
+| 6.2.7 Numerical input and output | incomplete | only partial support supplied. |
 | 6.3 Booleans | yes | |
 | 6.4 Pairs and lists | yes | `list?` is safe for using against circular list. |
 | 6.5 Symbols | yes | |

extlib/xfile

@@ -1 +1 @@
-Subproject commit 476dadc8f243488791acda8a6ecc208c4f4b95a7
+Subproject commit c7d08eb1abc829f3380991d3754a1ef6ce539c4d

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/number.c

@@ -7,6 +7,7 @@
 #include <stdlib.h>
 
 #include "picrin.h"
+#include "picrin/string.h"
 
 static int
 gcd(int a, int b)
@@ -679,6 +680,57 @@ pic_number_exact(pic_state *pic)
   return pic_int_value((int)round(f));
 }
 
+static pic_value
+pic_number_number_to_string(pic_state *pic)
+{
+  double f;
+  bool e;
+  int radix = 10;
+
+  pic_get_args(pic, "F|i", &f, &e, &radix);
+
+  if (e) {
+    char buf[snprintf(NULL, 0, "%d", (int)f) + 1];
+
+    snprintf(buf, sizeof buf, "%d", (int)f);
+
+    return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
+  }
+  else {
+    char buf[snprintf(NULL, 0, "%a", f) + 1];
+
+    snprintf(buf, sizeof buf, "%a", f);
+
+    return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
+  }
+}
+
+static pic_value
+pic_number_string_to_number(pic_state *pic)
+{
+  const char *str;
+  int radix = 10;
+  long num;
+  char *eptr;
+  double flo;
+
+  pic_get_args(pic, "z|i", &str, &radix);
+
+  num = strtol(str, &eptr, radix);
+  if (*eptr == '\0') {
+    return pic_valid_int(num)
+      ? pic_int_value(num)
+      : pic_float_value(num);
+  }
+
+  flo = strtod(str, &eptr);
+  if (*eptr == '\0') {
+    return pic_float_value(flo);
+  }
+
+  pic_errorf(pic, "invalid string given: %s", str);
+}
+
 void
 pic_init_number(pic_state *pic)
 {
@@ -745,6 +797,10 @@ pic_init_number(pic_state *pic)
   pic_defun(pic, "exact", pic_number_exact);
   pic_gc_arena_restore(pic, ai);
 
+  pic_defun(pic, "number->string", pic_number_number_to_string);
+  pic_defun(pic, "string->number", pic_number_string_to_number);
+  pic_gc_arena_restore(pic, ai);
+
   pic_deflibrary ("(scheme inexact)") {
     pic_defun(pic, "finite?", pic_number_finite_p);
     pic_defun(pic, "infinite?", pic_number_infinite_p);

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;