commit bb6d6a061ac7a25e316e567b51e3c764b78cd2af
parent 9ad4f101d2ef12678899d1a796791bacd54464cb
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 29 Nov 2011 19:57:40 -0300
Added new (common ASCII) character names from r7rs and r6rs to the reader and writer.
Diffstat:
5 files changed, 72 insertions(+), 11 deletions(-)
diff --git a/src/kobject.c b/src/kobject.c
@@ -1,5 +1,5 @@
/*
-** kobject.h
+** kobject.c
** Type definitions for Kernel Objects
** See Copyright Notice in klisp.h
*/
@@ -24,10 +24,19 @@ const TValue kipinf = KIPINF_;
const TValue kiminf = KIMINF_;
const TValue krwnpv = KRWNPV_;
const TValue kundef = KUNDEF_;
-const TValue kspace = KSPACE_;
-const TValue knewline = KNEWLINE_;
const TValue kfree = KFREE_;
+const TValue knull = KNULL_;
+const TValue kalarm = KALARM_;
+const TValue kbackspace = KBACKSPACE_;
+const TValue ktab = KTAB_;
+const TValue knewline = KNEWLINE_;
+const TValue kreturn = KRETURN_;
+const TValue kescape = KESCAPE_;
+const TValue kspace = KSPACE_;
+const TValue kdelete = KDELETE_;
+const TValue kvtab = KVTAB_;
+
/*
** The name strings for all TValue types
** This should be updated if types are modified in kobject.h
diff --git a/src/kobject.h b/src/kobject.h
@@ -610,9 +610,19 @@ union GCObject {
#define KIMINF_ {.tv = {.t = K_TAG_IINF, .v = { .i = -1 }}}
#define KRWNPV_ {.tv = {.t = K_TAG_RWNPV, .v = { .i = 0 }}}
#define KUNDEF_ {.tv = {.t = K_TAG_UNDEFINED, .v = { .i = 0 }}}
-#define KSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = ' ' }}}
-#define KNEWLINE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\n' }}}
#define KFREE_ {.tv = {.t = K_TAG_FREE, .v = { .i = 0 }}}
+/* named character */
+/* N.B. don't confuse with KNULL_ with KNIL!!! */
+#define KNULL_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\0' }}}
+#define KALARM_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\a' }}}
+#define KBACKSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\b' }}}
+#define KTAB_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\t' }}}
+#define KNEWLINE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\n' }}}
+#define KRETURN_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\r' }}}
+#define KESCAPE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\x1b' }}}
+#define KSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = ' ' }}}
+#define KDELETE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\x7f' }}}
+#define KVTAB_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\v' }}}
/* RATIONALE: the ones above can be used in initializers */
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -720,8 +720,24 @@ struct kspecial_token {
{ "#i-infinity", KIMINF_ },
{ "#real", KRWNPV_ },
{ "#undefined", KUNDEF_ },
- { "#\\space", KSPACE_ },
- { "#\\newline", KNEWLINE_ }
+ /*
+ ** Character names
+ ** (r7rs + vtab and linefeed from r6rs)
+ */
+ { "#\\null", KNULL_ },
+ { "#\\alarm", KALARM_ },
+ { "#\\backspace", KBACKSPACE_ },
+ { "#\\tab", KTAB_ },
+ { "#\\newline", KNEWLINE_ }, /* kernel */
+ { "#\\return", KRETURN_ },
+ { "#\\escape", KESCAPE_ },
+ { "#\\space", KSPACE_ }, /* kernel */
+ { "#\\delete", KDELETE_ },
+ /* r6rs, only */
+ { "#\\vtab", KVTAB_ },
+ { "#\\linefeed", KNEWLINE_ }, /* same as \newline */
+ { "#\\esc", KESCAPE_ }, /* same as r7rs \escape */
+ { "#\\nul", KNULL_ } /* same as r7rs \NULL */
};
#define MAX_EXT_REP_SIZE 64 /* all special tokens have much than 64 chars */
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -372,11 +372,38 @@ void kwrite_scalar(klisp_State *K, TValue obj)
char ch = chvalue(obj);
char *ch_ptr;
- if (ch == '\n') {
+ switch (ch) {
+ case '\0':
+ ch_ptr = "null";
+ break;
+ case '\a':
+ ch_ptr = "alarm";
+ break;
+ case '\b':
+ ch_ptr = "backspace";
+ break;
+ case '\t':
+ ch_ptr = "tab";
+ break;
+ case '\n':
ch_ptr = "newline";
- } else if (ch == ' ') {
+ break;
+ case '\r':
+ ch_ptr = "return";
+ break;
+ case '\x1b':
+ ch_ptr = "escape";
+ break;
+ case ' ':
ch_ptr = "space";
- } else {
+ break;
+ case '\x7f':
+ ch_ptr = "delete";
+ break;
+ case '\v':
+ ch_ptr = "vtab";
+ break;
+ default:
ch_buf[0] = ch;
ch_buf[1] = '\0';
ch_ptr = ch_buf;
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -158,7 +158,6 @@
($check-error (call-with-closed-input-port close-output-file))
;; 15.1.7 read
-
($check-predicate (eof-object? ($input-test #inert (read))))
($check-predicate (eof-object? ($input-test "" (read))))
