src/reader.c

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