diff --git a/README.md b/README.md index ed2cea05..473d68f9 100644 --- a/README.md +++ b/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 | | diff --git a/extlib/xfile b/extlib/xfile index 476dadc8..c7d08eb1 160000 --- a/extlib/xfile +++ b/extlib/xfile @@ -1 +1 @@ -Subproject commit 476dadc8f243488791acda8a6ecc208c4f4b95a7 +Subproject commit c7d08eb1abc829f3380991d3754a1ef6ce539c4d diff --git a/include/picrin/parse.h b/include/picrin/parse.h index afed3c34..0451d201 100644 --- a/include/picrin/parse.h +++ b/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; }; diff --git a/include/picrin/util.h b/include/picrin/util.h index 3475caae..1ad80950 100644 --- a/include/picrin/util.h +++ b/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 diff --git a/src/macro.c b/src/macro.c index c0e70845..dd92fba9 100644 --- a/src/macro.c +++ b/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); diff --git a/src/number.c b/src/number.c index e2f4ebb0..a73eb785 100644 --- a/src/number.c +++ b/src/number.c @@ -7,6 +7,7 @@ #include #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); diff --git a/src/read.c b/src/read.c index ac9fc247..4b0736b6 100644 --- a/src/read.c +++ b/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; } diff --git a/src/scan.l b/src/scan.l index a193dd68..c3d9b1b8 100644 --- a/src/scan.l +++ b/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); +} += { + BEGIN(INITIAL); + return tLABEL_SET; +} +# { + BEGIN(INITIAL); + return tLABEL_REF; +} + "#;" return tDATUM_COMMENT; "." return tDOT; "(" return tLPAREN;