src/reader.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of Mes.
   6  *
   7  * Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * Mes is distributed in the hope that it will be useful, but
  13  * WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 #include <ctype.h>
  22
  23 SCM
  24 read_input_file_env_ (SCM e, SCM a)
  25 {
  26   if (e == cell_nil)
  27     return e;
  28   return cons (e, read_input_file_env_ (read_env (a), a));
  29 }
  30
  31 SCM
  32 read_input_file_env (SCM a)
  33 {
  34   r0 = a;
  35 #if 0
  36   if (assq_ref_env (cell_symbol_read_input_file, r0) != cell_undefined)
  37     return apply (cell_symbol_read_input_file, cell_nil, r0);
  38 #endif
  39   return read_input_file_env_ (read_env (r0), r0);
  40 }
  41
  42 int
  43 reader_read_line_comment (int c)
  44 {
  45   if (c == '\n')
  46     return c;
  47   return reader_read_line_comment (getchar ());
  48 }
  49
  50 SCM reader_read_block_comment (int s, int c);
  51 SCM reader_read_hash (int c, SCM a);
  52 SCM reader_read_list (int c, SCM a);
  53
  54 int
  55 reader_identifier_p (int c)
  56 {
  57   return (c > ' ' && c <= '~' && c != '"' && c != ';' && c != '(' && c != ')' && c != EOF);
  58 }
  59
  60 int
  61 reader_end_of_word_p (int c)
  62 {
  63   return (c == '"' || c == ';' || c == '(' || c == ')' || isspace (c) || c == EOF);
  64 }
  65
  66 SCM
  67 reader_read_identifier_or_number (int c)
  68 {
  69   char buf[1024];
  70   int i = 0;
  71   int n = 0;
  72   int negative_p = 0;
  73   if (c == '+' && isdigit (peekchar ()))
  74     c = getchar ();
  75   else if (c == '-' && isdigit (peekchar ()))
  76     {
  77       negative_p = 1;
  78       c = getchar ();
  79     }
  80   while (isdigit (c))
  81     {
  82       buf[i++] = c;
  83       n *= 10;
  84       n += c - '0';
  85       c = getchar ();
  86     }
  87   if (reader_end_of_word_p (c))
  88     {
  89       ungetchar (c);
  90       if (negative_p)
  91         n = 0 - n;
  92       return MAKE_NUMBER (n);
  93     }
  94   while (!reader_end_of_word_p (c))
  95     {
  96       buf[i++] = c;
  97       c = getchar ();
  98     }
  99   ungetchar (c);
 100   buf[i] = 0;
 101   return lookup_symbol_ (cstring_to_list (buf));
 102 }
 103
 104 SCM
 105 reader_read_sexp_ (int c, SCM a)
 106 {
 107   SCM s = cell_nil;
 108   switch (c)
 109     {
 110     case EOF:
 111       return cell_nil;
 112     case ';':
 113       reader_read_line_comment (c);
 114     case ' ':
 115     case '\t':
 116     case '\n':
 117     case '\f':
 118       return reader_read_sexp_ (getchar (), a);
 119     case '(':
 120       return reader_read_list (getchar (), a);
 121     case  ')':
 122       return cell_nil;
 123     case '#':
 124       return reader_read_hash (getchar (), a);
 125     case '`':
 126       return cons (cell_symbol_quasiquote,
 127                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
 128     case ',':
 129       if (peekchar () == '@')
 130         {
 131           getchar ();
 132           return cons (cell_symbol_unquote_splicing,
 133                        cons (reader_read_sexp_ (getchar (), a), cell_nil));
 134         }
 135       return cons (cell_symbol_unquote,
 136                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
 137     case '\'':
 138       return cons (cell_symbol_quote,
 139                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
 140     case '"':
 141       return reader_read_string ();
 142     case '.':
 143       if (!reader_identifier_p (peekchar ()))
 144         return cell_dot;
 145     default:
 146       return reader_read_identifier_or_number (c);
 147     }
 148 }
 149
 150 int
 151 reader_eat_whitespace (int c)
 152 {
 153   while (isspace (c))
 154     c = getchar ();
 155   if (c == ';')
 156     return reader_eat_whitespace (reader_read_line_comment (c));
 157   if (c == '#' && (peekchar () == '!' || peekchar () == '|'))
 158     {
 159       c=getchar ();
 160       reader_read_block_comment (c, getchar ());
 161       return reader_eat_whitespace (getchar ());
 162     }
 163   return c;
 164 }
 165
 166 SCM
 167 reader_read_list (int c, SCM a)
 168 {
 169   c = reader_eat_whitespace (c);
 170   if (c == ')')
 171     return cell_nil;
 172   if (c == EOF)
 173     error (cell_symbol_not_a_pair, MAKE_STRING (cstring_to_list ("EOF in list")));
 174     //return cell_nil;
 175   SCM s = reader_read_sexp_ (c, a);
 176   if (s == cell_dot)
 177     return CAR (reader_read_list (getchar (), a));
 178   return cons (s, reader_read_list (getchar (), a));
 179 }
 180
 181 SCM
 182 read_env (SCM a)
 183 {
 184   return reader_read_sexp_ (getchar (), a);
 185 }
 186
 187 SCM
 188 reader_read_block_comment (int s, int c)
 189 {
 190   if (c == s && peekchar () == '#') return getchar ();
 191   return reader_read_block_comment (s, getchar ());
 192 }
 193
 194 SCM
 195 reader_read_hash (int c, SCM a)
 196 {
 197   switch (c)
 198     {
 199     case '!':
 200       reader_read_block_comment (c, getchar ());
 201       return reader_read_sexp_ (getchar (), a);
 202     case '|':
 203       reader_read_block_comment (c, getchar ());
 204       return reader_read_sexp_ (getchar (), a);
 205     case 'f':
 206       return cell_f;
 207     case 't':
 208       return cell_t;
 209     case ',':
 210       if (peekchar () == '@')
 211         {
 212           getchar ();
 213           return cons (cell_symbol_unsyntax_splicing,
 214                        cons (reader_read_sexp_ (getchar (), a),
 215                              cell_nil));
 216         }
 217       return cons (cell_symbol_unsyntax,
 218                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
 219     case '\'':
 220       return cons (cell_symbol_syntax,
 221                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
 222     case '`':
 223       return cons (cell_symbol_quasisyntax,
 224                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
 225     case ':':
 226     return MAKE_KEYWORD (CAR (reader_read_sexp_ (getchar (), a)));
 227     case 'o':
 228       return reader_read_octal ();
 229     case 'x':
 230       return reader_read_hex ();
 231     case '\\':
 232       return reader_read_character ();
 233     case '(':
 234       return list_to_vector (reader_read_list (getchar (), a));
 235     case ';':
 236       reader_read_sexp_ (getchar (), a);
 237       return reader_read_sexp_ (getchar (), a);
 238     }
 239   return reader_read_sexp_ (getchar (), a);
 240 }
 241
 242 SCM
 243 reader_read_sexp (SCM c, SCM s, SCM a)
 244 {
 245   return reader_read_sexp_ (VALUE (c), a);
 246 }
 247
 248 SCM
 249 reader_read_character ()
 250 {
 251   int c = getchar ();
 252   if (c >= '0' && c <= '7'
 253       && peekchar () >= '0' && peekchar () <= '7')
 254     {
 255       c = c - '0';
 256       while (peekchar () >= '0' && peekchar () <= '7')
 257         {
 258           c <<= 3;
 259           c += getchar () - '0';
 260         }
 261     }
 262   else if (((c >= 'a' && c <= 'z')
 263             || c == '*')
 264            && ((peekchar () >= 'a' && peekchar () <= 'z')
 265                || peekchar () == '*'))
 266     {
 267       char buf[10];
 268       char *p = buf;
 269       *p++ = c;
 270       while ((peekchar () >= 'a' && peekchar () <= 'z')
 271              || peekchar () == '*')
 272         {
 273           *p++ = getchar ();
 274         }
 275       *p = 0;
 276       if (!strcmp (buf, "*eof*")) c = EOF;
 277       else if (!strcmp (buf, "nul")) c = '\0';
 278       else if (!strcmp (buf, "alarm")) c = '\a';
 279       else if (!strcmp (buf, "backspace")) c = '\b';
 280       else if (!strcmp (buf, "tab")) c = '\t';
 281       else if (!strcmp (buf, "linefeed")) c = '\n';
 282       else if (!strcmp (buf, "newline")) c = '\n';
 283       else if (!strcmp (buf, "vtab")) c = '\v';
 284       else if (!strcmp (buf, "page")) c = '\f';
 285 #if 1 //__MESC__
 286       //Nyacc bug
 287       else if (!strcmp (buf, "return")) c = 13;
 288       else if (!strcmp (buf, "esc")) c = 27;
 289 #else
 290       else if (!strcmp (buf, "return")) c = '\r';
 291       //Nyacc crash else if (!strcmp (buf, "esc")) c = '\e';
 292 #endif
 293       else if (!strcmp (buf, "space")) c = ' ';
 294
 295 #if 1 // Nyacc uses old abbrevs
 296       else if (!strcmp (buf, "bel")) c = '\a';
 297       else if (!strcmp (buf, "bs")) c = '\b';
 298       else if (!strcmp (buf, "ht")) c = '\t';
 299       else if (!strcmp (buf, "vt")) c = '\v';
 300
 301 #if 1 //__MESC__
 302       //Nyacc bug
 303       else if (!strcmp (buf, "cr")) c = 13;
 304 #else
 305       else if (!strcmp (buf, "cr")) c = '\r';
 306 #endif
 307 #endif // Nyacc uses old abbrevs
 308
 309       else
 310         {
 311           eputs ("char not supported: ");
 312           eputs (buf);
 313           eputs ("\n");
 314 #if !__MESC__
 315           assert (!"char not supported");
 316 #endif
 317         }
 318     }
 319   return MAKE_CHAR (c);
 320 }
 321
 322 SCM
 323 reader_read_octal ()
 324 {
 325   int n = 0;
 326   int c = peekchar ();
 327   int s = 1;
 328   if (c == '-') {s = -1;getchar (); c = peekchar ();}
 329   while (c >= '0' && c <= '7')
 330     {
 331       n <<= 3;
 332       n+= c - '0';
 333       getchar ();
 334       c = peekchar ();
 335     }
 336   return MAKE_NUMBER (s*n);
 337 }
 338
 339 SCM
 340 reader_read_hex ()
 341 {
 342   int n = 0;
 343   int c = peekchar ();
 344   int s = 1;
 345   if (c == '-') {s = -1;getchar (); c = peekchar ();}
 346   while ((c >= '0' && c <= '9')
 347          || (c >= 'A' && c <= 'F')
 348          || (c >= 'a' && c <= 'f'))
 349     {
 350       n <<= 4;
 351       if (c >= 'a') n += c - 'a' + 10;
 352       else if (c >= 'A') n += c - 'A' + 10;
 353       else n+= c - '0';
 354       getchar ();
 355       c = peekchar ();
 356     }
 357   return MAKE_NUMBER (s*n);
 358 }
 359
 360 SCM
 361 reader_read_string ()
 362 {
 363   char buf[1024];
 364   SCM lst = cell_nil;
 365   int i = 0;
 366   int c = getchar ();
 367   while (1)
 368     {
 369       if (c == '"' || i > 1022)
 370         {
 371           buf[i] = 0;
 372           lst = append2 (lst, cstring_to_list (buf));
 373           i = 0;
 374           if (c == '"')
 375             break;
 376         }
 377       if (c == '\\')
 378         {
 379           int p = peekchar ();
 380           if (p == '\\' || p == '"')
 381             buf[i++] = getchar ();
 382           else if (p == 'n')
 383             {
 384               getchar ();
 385               buf[i++] = '\n';
 386             }
 387           else if (p == 't')
 388             {
 389               getchar ();
 390               buf[i++] = '\t';
 391             }
 392         }
 393 #if 0 // !__MESC__
 394       else if (c == EOF)
 395         assert (!"EOF in string");
 396 #endif
 397       else
 398         buf[i++] = c;
 399     c = getchar ();
 400   }
 401   return MAKE_STRING (lst);
 402 }
 403
 404 int g_tiny = 0;
 405
 406 int
 407 dump ()
 408 {
 409   r1 = g_symbols;
 410   gc_push_frame ();
 411   gc ();
 412   gc_peek_frame ();
 413   char *p = (char*)g_cells;
 414   putchar ('M');
 415   putchar ('E');
 416   putchar ('S');
 417   putchar (g_stack >> 8);
 418   putchar (g_stack % 256);
 419   eputs ("dumping\n");
 420   if (g_debug > 1)
 421     {
 422       eputs ("program r2=");
 423       display_error_ (r2);
 424       eputs ("\n");
 425     }
 426
 427   for (int i=0; i<g_free * sizeof (struct scm); i++)
 428     putchar (*p++);
 429   return 0;
 430 }