mes.c: display, newline: take optional port; add write-char, read hex #xXX.

This commit is contained in:
Jan Nieuwenhuizen 2016-08-12 14:17:20 +02:00
parent 066deeb183
commit 2097e9e4ef
1 changed files with 84 additions and 38 deletions

122
mes.c
View File

@ -69,7 +69,7 @@ typedef struct scm_t {
#define MES_C 1 #define MES_C 1
#include "mes.h" #include "mes.h"
scm *display_helper (scm*, bool, char*, bool); scm *display_helper (FILE*, scm*, bool, char*, bool);
bool bool
symbol_eq (scm *x, char *s) symbol_eq (scm *x, char *s)
{ {
@ -515,9 +515,20 @@ vector_p (scm *x)
} }
scm * scm *
display (scm *x) display (scm *x/*...*/)
{ {
return display_helper (x, false, "", false); scm *e = car (x);
scm *p = cdr (x);
int fd = 1;
if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
FILE *f = fd == 1 ? stdout : stderr;
return display_helper (f, e, false, "", false);
}
scm *
display_ (FILE* f, scm *x) //internal
{
return display_helper (f, x, false, "", false);
} }
scm * scm *
@ -909,66 +920,69 @@ vector_to_list (scm *v)
} }
scm * scm *
newline () newline (scm *p/*...*/)
{ {
puts (""); int fd = 1;
if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
FILE *f = fd == 1 ? stdout : stderr;
fputs ("\n", f);
return &scm_unspecified; return &scm_unspecified;
} }
scm * scm *
display_helper (scm *x, bool cont, char *sep, bool quote) display_helper (FILE* f, scm *x, bool cont, char *sep, bool quote)
{ {
scm *r; scm *r;
printf ("%s", sep); fprintf (f, "%s", sep);
if (x->type == CHAR && x->value == char_nul.value) printf ("#\\%s", char_nul.name); if (x->type == CHAR && x->value == char_nul.value) fprintf (f, "#\\%s", char_nul.name);
else if (x->type == CHAR && x->value == char_backspace.value) printf ("#\\%s", char_backspace.name); else if (x->type == CHAR && x->value == char_backspace.value) fprintf (f, "#\\%s", char_backspace.name);
else if (x->type == CHAR && x->value == char_tab.value) printf ("#\\%s", char_tab.name); else if (x->type == CHAR && x->value == char_tab.value) fprintf (f, "#\\%s", char_tab.name);
else if (x->type == CHAR && x->value == char_newline.value) printf ("#\\%s", char_newline.name); else if (x->type == CHAR && x->value == char_newline.value) fprintf (f, "#\\%s", char_newline.name);
else if (x->type == CHAR && x->value == char_vt.value) printf ("#\\%s", char_vt.name); else if (x->type == CHAR && x->value == char_vt.value) fprintf (f, "#\\%s", char_vt.name);
else if (x->type == CHAR && x->value == char_page.value) printf ("#\\%s", char_page.name); else if (x->type == CHAR && x->value == char_page.value) fprintf (f, "#\\%s", char_page.name);
else if (x->type == CHAR && x->value == char_return.value) printf ("#\\%s", char_return.name); else if (x->type == CHAR && x->value == char_return.value) fprintf (f, "#\\%s", char_return.name);
else if (x->type == CHAR && x->value == char_space.value) printf ("#\\%s", char_space.name); else if (x->type == CHAR && x->value == char_space.value) fprintf (f, "#\\%s", char_space.name);
else if (x->type == CHAR) printf ("#\\%c", x->value); else if (x->type == CHAR) fprintf (f, "#\\%c", x->value);
else if (x->type == MACRO) { else if (x->type == MACRO) {
printf ("(*macro* "); fprintf (f, "(*macro* ");
display_helper (x->macro, cont, sep, quote); display_helper (f, x->macro, cont, sep, quote);
printf (")"); fprintf (f, ")");
} }
else if (x->type == NUMBER) printf ("%d", x->value); else if (x->type == NUMBER) fprintf (f, "%d", x->value);
else if (x->type == PAIR) { else if (x->type == PAIR) {
if (car (x) == &symbol_circ) { if (car (x) == &symbol_circ) {
printf ("(*circ* . #-1#)"); fprintf (f, "(*circ* . #-1#)");
return &scm_unspecified; return &scm_unspecified;
} }
if (car (x) == &symbol_closure) { if (car (x) == &symbol_closure) {
printf ("(*closure* . #-1#)"); fprintf (f, "(*closure* . #-1#)");
return &scm_unspecified; return &scm_unspecified;
} }
if (car (x) == &scm_quote) { if (car (x) == &scm_quote) {
printf ("'"); fprintf (f, "'");
return display_helper (car (cdr (x)), cont, "", true); return display_helper (f, car (cdr (x)), cont, "", true);
} }
if (!cont) printf ("("); if (!cont) fprintf (f, "(");
display (car (x)); display_ (f, car (x));
if (cdr (x)->type == PAIR) if (cdr (x)->type == PAIR)
display_helper (cdr (x), true, " ", false); display_helper (f, cdr (x), true, " ", false);
else if (cdr (x) != &scm_nil) { else if (cdr (x) != &scm_nil) {
printf (" . "); fprintf (f, " . ");
display (cdr (x)); display_ (f, cdr (x));
} }
if (!cont) printf (")"); if (!cont) fprintf (f, ")");
} }
else if (x->type == VECTOR) { else if (x->type == VECTOR) {
printf ("#(", x->length); fprintf (f, "#(", x->length);
for (int i = 0; i < x->length; i++) { for (int i = 0; i < x->length; i++) {
if (x->vector[i]->type == VECTOR) if (x->vector[i]->type == VECTOR)
printf ("%s#(...)", i ? " " : ""); fprintf (f, "%s#(...)", i ? " " : "");
else else
display_helper (x->vector[i], false, i ? " " : "", false); display_helper (f, x->vector[i], false, i ? " " : "", false);
} }
printf (")"); fprintf (f, ")");
} }
else if (atom_p (x) == &scm_t) printf ("%s", x->name); else if (atom_p (x) == &scm_t) fprintf (f, "%s", x->name);
return &scm_unspecified; return &scm_unspecified;
} }
@ -1001,10 +1015,23 @@ read_char ()
return make_char (getchar ()); return make_char (getchar ());
} }
scm *
write_char (scm *x/*...*/)
{
scm *c = car (x);
scm *p = cdr (x);
int fd = 1;
if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
FILE *f = fd == 1 ? stdout : stderr;
assert (c->type == NUMBER || c->type == CHAR);
fputc (c->value, f);
return c;
}
scm* scm*
builtin_ungetchar (scm *c) builtin_ungetchar (scm *c)
{ {
assert (c->type == NUMBER); assert (c->type == NUMBER || c->type == CHAR);
ungetchar (c->value); ungetchar (c->value);
return c; return c;
} }
@ -1060,6 +1087,7 @@ readword (int c, char* w, scm *a)
cons (readword (getchar (), w, a), cons (readword (getchar (), w, a),
&scm_nil));} &scm_nil));}
if (c == ';') {readcomment (c); return readword ('\n', w, a);} if (c == ';') {readcomment (c); return readword ('\n', w, a);}
if (c == '#' && peek_char () == 'x') {getchar (); return read_hex ();}
if (c == '#' && peek_char () == '\\') {getchar (); return read_character ();} if (c == '#' && peek_char () == '\\') {getchar (); return read_character ();}
if (c == '#' && !w && peek_char () == '(') {getchar (); return list_to_vector (readlist (a));} if (c == '#' && !w && peek_char () == '(') {getchar (); return list_to_vector (readlist (a));}
if (c == '#' && peek_char () == '(') {ungetchar (c); return lookup (w, a);} if (c == '#' && peek_char () == '(') {ungetchar (c); return lookup (w, a);}
@ -1069,6 +1097,24 @@ readword (int c, char* w, scm *a)
return readword (getchar (), strncat (w ? w : buf, &ch, 1), a); return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
} }
scm *
read_hex ()
{
int n = 0;
int c = peek_char ();
while ((c >= '0' && c <= '9')
|| (c >= 'A' && c <= 'F')
|| (c >= 'a' && c <= 'f')) {
n <<= 4;
if (c >= 'a') n += c - 'a' + 10;
else if (c >= 'A') n += c - 'A' + 10;
else n+= c - '0';
getchar ();
c = peek_char ();
}
return make_number (n);
}
scm * scm *
read_character () read_character ()
{ {
@ -1370,7 +1416,7 @@ int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
scm *a = mes_environment (); scm *a = mes_environment ();
display (eval (cons (&symbol_begin, read_file (readenv (a), a)), a)); display_ (stderr, eval (cons (&symbol_begin, read_file (readenv (a), a)), a));
newline (); fputs ("", stderr);
return 0; return 0;
} }