core: reader: Prepare for M2-Planet.

* src/reader.c (MAX_STRING): New define.
(read_input_file_env_): Remove dead code.
(reader_read_line_comment): Refactor to remove recursion.
(reader_read_line_sexp_): Refactor to use if instead of switch.
(reader_read_hash): Likewise.
(reader_read_character): Refactor: cache peekchar () value, make
M2-Planet friendly.
(reader_read_binary): Make M2-Planet friendly.
(reader_read_octal): Likewise.
(reader_read_hex): Likewise.
(reader_read_string): Refactor.
(dump): Make M2-Planet friendly.
This commit is contained in:
Jan Nieuwenhuizen 2018-08-12 14:53:06 +02:00
parent 43f0c2d831
commit 03ee240904
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273

View file

@ -1,6 +1,7 @@
/* -*-comment-start: "//";comment-end:""-*- /* -*-comment-start: "//";comment-end:""-*-
* GNU Mes --- Maxwell Equations of Software * GNU Mes --- Maxwell Equations of Software
* Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2018 Jeremiah Orians <jeremiah@pdp10.guru>
* *
* This file is part of GNU Mes. * This file is part of GNU Mes.
* *
@ -20,6 +21,8 @@
#include <ctype.h> #include <ctype.h>
#define MAX_STRING 4096
SCM SCM
read_input_file_env_ (SCM e, SCM a) read_input_file_env_ (SCM e, SCM a)
{ {
@ -32,19 +35,20 @@ SCM
read_input_file_env (SCM a) read_input_file_env (SCM a)
{ {
r0 = a; r0 = a;
#if 0
if (assq_ref_env (cell_symbol_read_input_file, r0) != cell_undefined)
return apply (cell_symbol_read_input_file, cell_nil, r0);
#endif
return read_input_file_env_ (read_env (r0), r0); return read_input_file_env_ (read_env (r0), r0);
} }
int int
reader_read_line_comment (int c) reader_read_line_comment (int c)
{ {
if (c == '\n') while (c != EOF)
return c; {
return reader_read_line_comment (readchar ()); if (c == '\n')
return c;
c = readchar ();
}
error (cell_symbol_system_error,
MAKE_STRING (cstring_to_list ("reader_read_line_comment")));
} }
SCM reader_read_block_comment (int s, int c); SCM reader_read_block_comment (int s, int c);
@ -66,7 +70,7 @@ reader_end_of_word_p (int c)
SCM SCM
reader_read_identifier_or_number (int c) reader_read_identifier_or_number (int c)
{ {
char buf[1024]; char buf[MAX_STRING];
int i = 0; int i = 0;
int n = 0; int n = 0;
int negative_p = 0; int negative_p = 0;
@ -91,6 +95,7 @@ reader_read_identifier_or_number (int c)
n = 0 - n; n = 0 - n;
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
} }
/* Fallthrough: Note that `4a', `+1b' are identifiers */
while (!reader_end_of_word_p (c)) while (!reader_end_of_word_p (c))
{ {
buf[i++] = c; buf[i++] = c;
@ -104,28 +109,30 @@ reader_read_identifier_or_number (int c)
SCM SCM
reader_read_sexp_ (int c, SCM a) reader_read_sexp_ (int c, SCM a)
{ {
SCM s = cell_nil; reset_reader:
switch (c) if (c == EOF)
return cell_nil;
if (c == ';')
{
c = reader_read_line_comment (c);
goto reset_reader;
}
if ((c == ' ') || (c == '\t') || (c == '\n') || (c == '\f'))
{
c = readchar ();
goto reset_reader;
}
if (c == '(')
return reader_read_list (readchar (), a);
if (c == ')')
return cell_nil;
if (c == '#')
return reader_read_hash (readchar (), a);
if (c == '`')
return cons (cell_symbol_quasiquote,
cons (reader_read_sexp_ (readchar (), a), cell_nil));
if(c == ',')
{ {
case EOF:
return cell_nil;
case ';':
reader_read_line_comment (c);
case ' ':
case '\t':
case '\n':
case '\f':
return reader_read_sexp_ (readchar (), a);
case '(':
return reader_read_list (readchar (), a);
case ')':
return cell_nil;
case '#':
return reader_read_hash (readchar (), a);
case '`':
return cons (cell_symbol_quasiquote,
cons (reader_read_sexp_ (readchar (), a), cell_nil));
case ',':
if (peekchar () == '@') if (peekchar () == '@')
{ {
readchar (); readchar ();
@ -134,17 +141,15 @@ reader_read_sexp_ (int c, SCM a)
} }
return cons (cell_symbol_unquote, return cons (cell_symbol_unquote,
cons (reader_read_sexp_ (readchar (), a), cell_nil)); cons (reader_read_sexp_ (readchar (), a), cell_nil));
case '\'':
return cons (cell_symbol_quote,
cons (reader_read_sexp_ (readchar (), a), cell_nil));
case '"':
return reader_read_string ();
case '.':
if (!reader_identifier_p (peekchar ()))
return cell_dot;
default:
return reader_read_identifier_or_number (c);
} }
if (c == '\'')
return cons (cell_symbol_quote,
cons (reader_read_sexp_ (readchar (), a), cell_nil));
if (c == '"')
return reader_read_string ();
if (c == '.' && (!reader_identifier_p (peekchar ())))
return cell_dot;
return reader_read_identifier_or_number (c);
} }
int int
@ -194,47 +199,52 @@ reader_read_block_comment (int s, int c)
SCM SCM
reader_read_hash (int c, SCM a) reader_read_hash (int c, SCM a)
{ {
switch (c) if (c == '!')
{ {
case '!':
reader_read_block_comment (c, readchar ()); reader_read_block_comment (c, readchar ());
return reader_read_sexp_ (readchar (), a); return reader_read_sexp_ (readchar (), a);
case '|': }
if (c == '|')
{
reader_read_block_comment (c, readchar ()); reader_read_block_comment (c, readchar ());
return reader_read_sexp_ (readchar (), a); return reader_read_sexp_ (readchar (), a);
case 'f': }
return cell_f; if(c == 'f')
case 't': return cell_f;
return cell_t; if(c == 't')
case ',': return cell_t;
if(c == ',')
{
if (peekchar () == '@') if (peekchar () == '@')
{ {
readchar (); readchar ();
return cons (cell_symbol_unsyntax_splicing, return cons (cell_symbol_unsyntax_splicing,
cons (reader_read_sexp_ (readchar (), a), cons (reader_read_sexp_ (readchar (), a), cell_nil));
cell_nil));
} }
return cons (cell_symbol_unsyntax, return cons (cell_symbol_unsyntax,
cons (reader_read_sexp_ (readchar (), a), cell_nil)); cons (reader_read_sexp_ (readchar (), a), cell_nil));
case '\'': }
return cons (cell_symbol_syntax, if (c == '\'')
cons (reader_read_sexp_ (readchar (), a), cell_nil)); return cons (cell_symbol_syntax,
case '`': cons (reader_read_sexp_ (readchar (), a), cell_nil));
return cons (cell_symbol_quasisyntax, if (c == '`')
cons (reader_read_sexp_ (readchar (), a), cell_nil)); return cons (cell_symbol_quasisyntax,
case ':': cons (reader_read_sexp_ (readchar (), a), cell_nil));
if (c == ':')
return MAKE_KEYWORD (CAR (reader_read_sexp_ (readchar (), a))); return MAKE_KEYWORD (CAR (reader_read_sexp_ (readchar (), a)));
case 'b': if (c == 'b')
return reader_read_binary (); return reader_read_binary ();
case 'o': if (c == 'o')
return reader_read_octal (); return reader_read_octal ();
case 'x': if (c == 'x')
return reader_read_hex (); return reader_read_hex ();
case '\\': if (c == '\\')
return reader_read_character (); return reader_read_character ();
case '(': if (c == '(')
return list_to_vector (reader_read_list (readchar (), a)); return list_to_vector (reader_read_list (readchar (), a));
case ';': if (c == ';')
{
reader_read_sexp_ (readchar (), a); reader_read_sexp_ (readchar (), a);
return reader_read_sexp_ (readchar (), a); return reader_read_sexp_ (readchar (), a);
} }
@ -251,30 +261,35 @@ SCM
reader_read_character () reader_read_character ()
{ {
int c = readchar (); int c = readchar ();
int p = peekchar ();
int i = 0;
if (c >= '0' && c <= '7' if (c >= '0' && c <= '7'
&& peekchar () >= '0' && peekchar () <= '7') && p >= '0' && p <= '7')
{ {
c = c - '0'; c = c - '0';
while (peekchar () >= '0' && peekchar () <= '7') while (p >= '0' && p <= '7')
{ {
c <<= 3; c <<= 3;
c += readchar () - '0'; c += readchar () - '0';
p = peekchar ();
} }
} }
else if (((c >= 'a' && c <= 'z') else if (((c >= 'a' && c <= 'z')
|| c == '*') || c == '*')
&& ((peekchar () >= 'a' && peekchar () <= 'z') && ((p >= 'a' && p <= 'z')
|| peekchar () == '*')) || p == '*'))
{ {
char buf[10]; char buf[10];
char *p = buf; buf[i] = c;
*p++ = c; i = i + 1;
while ((peekchar () >= 'a' && peekchar () <= 'z') while ((p >= 'a' && p <= 'z')
|| peekchar () == '*') || p == '*')
{ {
*p++ = readchar (); buf[i] = readchar ();
i = i + 1;
p = peekchar ();
} }
*p = 0; buf[i] = 0;
if (!strcmp (buf, "*eof*")) c = EOF; if (!strcmp (buf, "*eof*")) c = EOF;
else if (!strcmp (buf, "nul")) c = '\0'; else if (!strcmp (buf, "nul")) c = '\0';
else if (!strcmp (buf, "alarm")) c = '\a'; else if (!strcmp (buf, "alarm")) c = '\a';
@ -313,9 +328,8 @@ reader_read_character ()
eputs ("char not supported: "); eputs ("char not supported: ");
eputs (buf); eputs (buf);
eputs ("\n"); eputs ("\n");
#if !__MESC__ error (cell_symbol_system_error,
assert (!"char not supported"); MAKE_STRING (cstring_to_list ("char not supported")));
#endif
} }
} }
return MAKE_CHAR (c); return MAKE_CHAR (c);
@ -327,11 +341,16 @@ reader_read_binary ()
int n = 0; int n = 0;
int c = peekchar (); int c = peekchar ();
int s = 1; int s = 1;
if (c == '-') {s = -1; readchar (); c = peekchar ();} if (c == '-')
{
s = -1;
readchar ();
c = peekchar ();
}
while (c == '0' || c == '1') while (c == '0' || c == '1')
{ {
n <<= 1; n = n << 1;
n+= c - '0'; n = n + c - '0';
readchar (); readchar ();
c = peekchar (); c = peekchar ();
} }
@ -344,11 +363,16 @@ reader_read_octal ()
int n = 0; int n = 0;
int c = peekchar (); int c = peekchar ();
int s = 1; int s = 1;
if (c == '-') {s = -1;readchar (); c = peekchar ();} if (c == '-')
{
s = -1;
readchar ();
c = peekchar ();
}
while (c >= '0' && c <= '7') while (c >= '0' && c <= '7')
{ {
n <<= 3; n = n << 3;
n+= c - '0'; n = n + c - '0';
readchar (); readchar ();
c = peekchar (); c = peekchar ();
} }
@ -361,15 +385,23 @@ reader_read_hex ()
int n = 0; int n = 0;
int c = peekchar (); int c = peekchar ();
int s = 1; int s = 1;
if (c == '-') {s = -1;readchar (); c = peekchar ();} if (c == '-')
{
s = -1;
readchar ();
c = peekchar ();
}
while ((c >= '0' && c <= '9') while ((c >= '0' && c <= '9')
|| (c >= 'A' && c <= 'F') || (c >= 'A' && c <= 'F')
|| (c >= 'a' && c <= 'f')) || (c >= 'a' && c <= 'f'))
{ {
n <<= 4; n = n << 4;
if (c >= 'a') n += c - 'a' + 10; if (c >= 'a')
else if (c >= 'A') n += c - 'A' + 10; n = n + c - 'a' + 10;
else n+= c - '0'; else if (c >= 'A')
n = n + c - 'A' + 10;
else
n = n + c - '0';
readchar (); readchar ();
c = peekchar (); c = peekchar ();
} }
@ -379,83 +411,46 @@ reader_read_hex ()
SCM SCM
reader_read_string () reader_read_string ()
{ {
char buf[1024];
SCM lst = cell_nil; SCM lst = cell_nil;
int i = 0; int c;
int c = readchar (); do
while (1)
{ {
if (c == '"' || i > 1022) c = readchar ();
{ if (c == '"')
buf[i] = 0; break;
lst = append2 (lst, string_to_list (buf, i));
i = 0;
if (c == '"')
break;
}
if (c == '\\') if (c == '\\')
{ {
int p = peekchar (); c = readchar ();
if (p == '\\' || p == '"') if (c == '\\' || c == '"')
buf[i++] = readchar (); lst = cons (MAKE_CHAR (c), lst);
else if (p == '0') else if (c == '0')
{ lst = cons (MAKE_CHAR ('\0'), lst);
readchar (); else if (c == 'a')
buf[i++] = '\0'; lst = cons (MAKE_CHAR ('\a'), lst);
} else if (c == 'b')
else if (p == 'a') lst = cons (MAKE_CHAR ('\b'), lst);
{ else if (c == 't')
readchar (); lst = cons (MAKE_CHAR ('\t'), lst);
buf[i++] = '\a'; else if (c == 'n')
} lst = cons (MAKE_CHAR ('\n'), lst);
else if (p == 'b') else if (c == 'v')
{ lst = cons (MAKE_CHAR ('\v'), lst);
readchar (); else if (c == 'f')
buf[i++] = '\b'; lst = cons (MAKE_CHAR ('\f'), lst);
} else if (c == 'r')
else if (p == 't') // Nyacc bug
{ // lst = cons (MAKE_CHAR ('\r'), lst);
readchar (); lst = cons (MAKE_CHAR (13), lst);
buf[i++] = '\t'; else if (c == 'e')
} // Nyacc bug
else if (p == 'n') // lst = cons (MAKE_CHAR ('\e'), lst);
{ lst = cons (MAKE_CHAR (27), lst);
readchar ();
buf[i++] = '\n';
}
else if (p == 'v')
{
readchar ();
buf[i++] = '\v';
}
else if (p == 'f')
{
readchar ();
buf[i++] = '\f';
}
else if (p == 'r')
{
readchar ();
//Nyacc bug
//buf[i++] = '\r';
buf[i++] = 13;
}
else if (p == 'e')
{
readchar ();
//buf[i++] = '\e';
buf[i++] = 27;
}
} }
#if 0 // !__MESC__
else if (c == EOF)
assert (!"EOF in string");
#endif
else else
buf[i++] = c; lst = cons (MAKE_CHAR (c), lst);
c = readchar (); }
} while (1);
return MAKE_STRING (lst); return MAKE_STRING (reverse_x_ (lst, cell_nil));
} }
int g_tiny = 0; int g_tiny = 0;
@ -512,7 +507,11 @@ dump ()
eputs ("\n"); eputs ("\n");
} }
for (int i=0; i<g_free * sizeof (struct scm); i++) int i;
putchar (*p++); for (i=0; i<g_free * sizeof (struct scm); i = i + 1)
{
putchar (p[0]);
p = p + 1;
}
return 0; return 0;
} }