diff --git a/TODO b/TODO index 46e8293d..399e3a1f 100644 --- a/TODO +++ b/TODO @@ -14,16 +14,16 @@ v "string" #\CHAR assq call-with-values -char? +v char? length -list +v list list->vector make-vector memv -string +v string v string-append v string? -symbol? +v symbol? values vector vector->list diff --git a/mes.c b/mes.c index 1774c64b..dfb6924f 100644 --- a/mes.c +++ b/mes.c @@ -42,7 +42,7 @@ #define QUOTE_SUGAR 1 #endif -enum type {STRING, SYMBOL, NUMBER, PAIR, +enum type {STRING, SYMBOL, CHAR, NUMBER, PAIR, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn}; struct scm_t; typedef struct scm_t* (*function0_t) (void); @@ -140,10 +140,14 @@ scm * eq_p (scm *x, scm *y) { return (x == y + || (x->type == CHAR && y->type == CHAR + && x->value == y->value) || (x->type == NUMBER && y->type == NUMBER && x->value == y->value) // FIXME: alist lookup symbols || (atom_p (x) == &scm_t + && x->type != CHAR + && y->type != CHAR && x->type != NUMBER && y->type != NUMBER && atom_p (y) == &scm_t @@ -298,7 +302,9 @@ eval_ (scm *e, scm *a) display (e); puts (""); #endif - if (e->type == NUMBER) + if (e->type == CHAR) + return e; + else if (e->type == NUMBER) return e; else if (e->type == STRING) return e; @@ -414,6 +420,12 @@ builtin_p (scm *x) ? &scm_t : &scm_f; } +scm * +char_p (scm *x) +{ + return x->type == CHAR ? &scm_t : &scm_f; +} + scm * number_p (scm *x) { @@ -474,6 +486,15 @@ append (scm *x, scm *y) return cons (car (x), append (cdr (x), y)); } +scm * +make_char (int x) +{ + scm *p = malloc (sizeof (scm)); + p->type = CHAR; + p->value = x; + return p; +} + scm * make_number (int x) { @@ -502,6 +523,21 @@ make_symbol (char const *s) return p; } +scm * +string (scm *x/*...*/) +{ + char buf[256] = ""; + char *p = buf; + while (x != &scm_nil) + { + scm *s = car (x); + assert (s->type == CHAR); + *p++ = s->value; + x = cdr (x); + } + return make_string (buf); +} + scm * string_append (scm *x/*...*/) { @@ -599,7 +635,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote) { scm *r; printf ("%s", sep); - if (x->type == NUMBER) printf ("%d", x->value); + if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline"); + else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space"); + else if (x->type == CHAR) printf ("#\\%c", x->value); + else if (x->type == NUMBER) printf ("%d", x->value); else if (x->type == PAIR) { #if QUOTE_SUGAR if (car (x) == &scm_quote) { @@ -708,12 +747,44 @@ readword (int c, char* w, scm *a) cons (readword (getchar (), w, a), &scm_nil));} if (c == ';') {readcomment (c); return readword ('\n', w, a);} + if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();} if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);} char buf[256] = {0}; char ch = c; return readword (getchar (), strncat (w ? w : buf, &ch, 1), a); } +scm * +readchar () +{ + int c = getchar (); + if (c >= '0' && c <= '7' + && peekchar () >= '0' && peekchar () <= '7') { + c = c - '0'; + while (peekchar () >= '0' && peekchar () <= '7') { + c <<= 3; + c += getchar () - '0'; + } + } + else if (c >= 'a' && c <= 'z' + && peekchar () >= 'a' && peekchar () <= 'z') { + char buf[256]; + char *p = buf; + *p++ = c; + while (peekchar () >= 'a' && peekchar () <= 'z') { + *p++ = getchar (); + } + *p = 0; + if (!strcmp (buf, "newline")) c = 10; + else if (!strcmp (buf, "space")) c = 32; + else { + printf ("char not supported: %s", buf); + assert (!"char not supported"); + } + } + return make_char (c); +} + scm * readstring () { diff --git a/mes.mes b/mes.mes index 7d25a7b9..9650bf7e 100644 --- a/mes.mes +++ b/mes.mes @@ -121,9 +121,10 @@ ;; (display a) ;; (newline) (cond - ((number? e) e) ((eq? e #t) #t) ((eq? e #f) #f) + ((char? e) e) + ((number? e) e) ((string? e) e) ((atom? e) (cdr (assoc e a))) ((builtin? e) e) diff --git a/test.mes b/test.mes index 3143266e..2eff4e96 100644 --- a/test.mes +++ b/test.mes @@ -169,4 +169,17 @@ (display (string-length (string-append "a" "b" "c"))) (newline) +#\m +(display #\m) +(newline) +(display #\101) +(newline) +(display #\newline) +(newline) +(display #\space) +(newline) + +(display (string #\a #\space #\s #\t #\r #\i #\n #\g #\newline)) +(newline) + '()