guile18/libguile/read.c

   1 /* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008 Free Software
   2  * Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2.1 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include <stdio.h>
  27 #include <ctype.h>
  28 #include <string.h>
  29 #ifdef HAVE_STRINGS_H
  30 # include <strings.h>
  31 #endif
  32
  33 #include "libguile/_scm.h"
  34 #include "libguile/chars.h"
  35 #include "libguile/eval.h"
  36 #include "libguile/unif.h"
  37 #include "libguile/keywords.h"
  38 #include "libguile/alist.h"
  39 #include "libguile/srcprop.h"
  40 #include "libguile/hashtab.h"
  41 #include "libguile/hash.h"
  42 #include "libguile/ports.h"
  43 #include "libguile/root.h"
  44 #include "libguile/strings.h"
  45 #include "libguile/strports.h"
  46 #include "libguile/vectors.h"
  47 #include "libguile/validate.h"
  48 #include "libguile/srfi-4.h"
  49 #include "libguile/srfi-13.h"
  50
  51 #include "libguile/read.h"
  52
  53 \f
  54
  55 SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
  56 SCM_SYMBOL (scm_keyword_prefix, "prefix");
  57 SCM_SYMBOL (scm_keyword_postfix, "postfix");
  58
  59 scm_t_option scm_read_opts[] = {
  60   { SCM_OPTION_BOOLEAN, "copy", 0,
  61     "Copy source code expressions." },
  62   { SCM_OPTION_BOOLEAN, "positions", 0,
  63     "Record positions of source code expressions." },
  64   { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
  65     "Convert symbols to lower case."},
  66   { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
  67     "Style of keyword recognition: #f, 'prefix or 'postfix."}
  68 #if SCM_ENABLE_ELISP
  69   ,
  70   { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
  71     "Support Elisp vector syntax, namely `[...]'."},
  72   { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
  73     "Support `\\(' and `\\)' in strings."}
  74 #endif
  75 };
  76
  77 /*
  78   Give meaningful error messages for errors
  79
  80   We use the format
  81
  82   FILE:LINE:COL: MESSAGE
  83   This happened in ....
  84
  85   This is not standard GNU format, but the test-suite likes the real
  86   message to be in front.
  87
  88  */
  89
  90
  91 void
  92 scm_i_input_error (char const *function,
  93                    SCM port, const char *message, SCM arg)
  94 {
  95   SCM fn = (scm_is_string (SCM_FILENAME(port))
  96             ? SCM_FILENAME(port)
  97             : scm_from_locale_string ("#<unknown port>"));
  98
  99   SCM string_port = scm_open_output_string ();
 100   SCM string = SCM_EOL;
 101   scm_simple_format (string_port,
 102                      scm_from_locale_string ("~A:~S:~S: ~A"),
 103                      scm_list_4 (fn,
 104                                  scm_from_long (SCM_LINUM (port) + 1),
 105                                  scm_from_int (SCM_COL (port) + 1),
 106                                  scm_from_locale_string (message)));
 107
 108   string = scm_get_output_string (string_port);
 109   scm_close_output_port (string_port);
 110   scm_error_scm (scm_from_locale_symbol ("read-error"),
 111                  function? scm_from_locale_string (function) : SCM_BOOL_F,
 112                  string,
 113                  arg,
 114                  SCM_BOOL_F);
 115 }
 116
 117
 118 SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
 119             (SCM setting),
 120             "Option interface for the read options. Instead of using\n"
 121             "this procedure directly, use the procedures @code{read-enable},\n"
 122             "@code{read-disable}, @code{read-set!} and @code{read-options}.")
 123 #define FUNC_NAME s_scm_read_options
 124 {
 125   SCM ans = scm_options (setting,
 126                          scm_read_opts,
 127                          SCM_N_READ_OPTIONS,
 128                          FUNC_NAME);
 129   if (SCM_COPY_SOURCE_P)
 130     SCM_RECORD_POSITIONS_P = 1;
 131   return ans;
 132 }
 133 #undef FUNC_NAME
 134
 135 /* An association list mapping extra hash characters to procedures.  */
 136 static SCM *scm_read_hash_procedures;
 137
 138
 139 \f
 140 /* Token readers.  */
 141
 142
 143 /* Size of the C buffer used to read symbols and numbers.  */
 144 #define READER_BUFFER_SIZE            128
 145
 146 /* Size of the C buffer used to read strings.  */
 147 #define READER_STRING_BUFFER_SIZE     512
 148
 149 /* The maximum size of Scheme character names.  */
 150 #define READER_CHAR_NAME_MAX_SIZE      50
 151
 152
 153 /* `isblank' is only in C99.  */
 154 #define CHAR_IS_BLANK_(_chr)                                    \
 155   (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n')      \
 156    || ((_chr) == '\f') || ((_chr) == '\r'))
 157
 158 #ifdef MSDOS
 159 # define CHAR_IS_BLANK(_chr)                    \
 160   ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
 161 #else
 162 # define CHAR_IS_BLANK CHAR_IS_BLANK_
 163 #endif
 164
 165
 166 /* R5RS one-character delimiters (see section 7.1.1, ``Lexical
 167    structure'').  */
 168 #define CHAR_IS_R5RS_DELIMITER(c)                               \
 169   (CHAR_IS_BLANK (c)                                            \
 170    || (c == ')') || (c == '(') || (c == ';') || (c == '"'))
 171
 172 #define CHAR_IS_DELIMITER  CHAR_IS_R5RS_DELIMITER
 173
 174 /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
 175    Structure''.  */
 176 #define CHAR_IS_EXPONENT_MARKER(_chr)                           \
 177   (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f')        \
 178    || ((_chr) == 'd') || ((_chr) == 'l'))
 179
 180 /* An inlinable version of `scm_c_downcase ()'.  */
 181 #define CHAR_DOWNCASE(_chr)                             \
 182   (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
 183
 184
 185 #ifndef HAVE_DECL_STRNCASECMP
 186 extern int strncasecmp (char const *s1, char const *s2, size_t n);
 187 #endif
 188
 189 #ifndef HAVE_STRNCASECMP
 190 /* XXX: Use Gnulib's `strncasecmp ()'.  */
 191
 192 static int
 193 strncasecmp (const char *s1, const char *s2, size_t len2)
 194 {
 195   while (*s1 && *s2 && len2 > 0)
 196     {
 197       int c1 = *s1, c2 = *s2;
 198
 199       if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2))
 200         return 0;
 201       else
 202         {
 203           ++s1;
 204           ++s2;
 205           --len2;
 206         }
 207     }
 208   return !(*s1 || *s2 || len2 > 0);
 209 }
 210 #endif
 211
 212
 213 /* Read an SCSH block comment.  */
 214 static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
 215
 216 /* Read from PORT until a delimiter (e.g., a whitespace) is read.  Return
 217    zero if the whole token fits in BUF, non-zero otherwise.  */
 218 static inline int
 219 read_token (SCM port, char *buf, size_t buf_size, size_t *read)
 220 {
 221   *read = 0;
 222
 223   while (*read < buf_size)
 224     {
 225       int chr;
 226
 227       chr = scm_getc (port);
 228       chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr);
 229
 230       if (chr == EOF)
 231         return 0;
 232       else if (CHAR_IS_DELIMITER (chr))
 233         {
 234           scm_ungetc (chr, port);
 235           return 0;
 236         }
 237       else
 238         {
 239           *buf = (char) chr;
 240           buf++, (*read)++;
 241         }
 242     }
 243
 244   return 1;
 245 }
 246
 247
 248 /* Skip whitespace from PORT and return the first non-whitespace character
 249    read.  Raise an error on end-of-file.  */
 250 static int
 251 flush_ws (SCM port, const char *eoferr)
 252 {
 253   register int c;
 254   while (1)
 255     switch (c = scm_getc (port))
 256       {
 257       case EOF:
 258       goteof:
 259         if (eoferr)
 260           {
 261             scm_i_input_error (eoferr,
 262                                port,
 263                                "end of file",
 264                                SCM_EOL);
 265           }
 266         return c;
 267
 268       case ';':
 269       lp:
 270         switch (c = scm_getc (port))
 271           {
 272           case EOF:
 273             goto goteof;
 274           default:
 275             goto lp;
 276           case SCM_LINE_INCREMENTORS:
 277             break;
 278           }
 279         break;
 280
 281       case '#':
 282         switch (c = scm_getc (port))
 283           {
 284           case EOF:
 285             eoferr = "read_sharp";
 286             goto goteof;
 287           case '!':
 288             scm_read_scsh_block_comment (c, port);
 289             break;
 290           default:
 291             scm_ungetc (c, port);
 292             return '#';
 293           }
 294         break;
 295
 296       case SCM_LINE_INCREMENTORS:
 297       case SCM_SINGLE_SPACES:
 298       case '\t':
 299         break;
 300
 301       default:
 302         return c;
 303       }
 304
 305   return 0;
 306 }
 307
 308
 309 \f
 310 /* Token readers.  */
 311
 312 static SCM scm_read_expression (SCM port);
 313 static SCM scm_read_sharp (int chr, SCM port);
 314 static SCM scm_get_hash_procedure (int c);
 315 static SCM recsexpr (SCM obj, long line, int column, SCM filename);
 316
 317
 318 static SCM
 319 scm_read_sexp (int chr, SCM port)
 320 #define FUNC_NAME "scm_i_lreadparen"
 321 {
 322   register int c;
 323   register SCM tmp;
 324   register SCM tl, ans = SCM_EOL;
 325   SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
 326   static const int terminating_char = ')';
 327
 328   /* Need to capture line and column numbers here. */
 329   long line = SCM_LINUM (port);
 330   int column = SCM_COL (port) - 1;
 331
 332
 333   c = flush_ws (port, FUNC_NAME);
 334   if (terminating_char == c)
 335     return SCM_EOL;
 336
 337   scm_ungetc (c, port);
 338   if (scm_is_eq (scm_sym_dot,
 339                  (tmp = scm_read_expression (port))))
 340     {
 341       ans = scm_read_expression (port);
 342       if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
 343         scm_i_input_error (FUNC_NAME, port, "missing close paren",
 344                            SCM_EOL);
 345       return ans;
 346     }
 347
 348   /* Build the head of the list structure. */
 349   ans = tl = scm_cons (tmp, SCM_EOL);
 350
 351   if (SCM_COPY_SOURCE_P)
 352     ans2 = tl2 = scm_cons (scm_is_pair (tmp)
 353                            ? copy
 354                            : tmp,
 355                            SCM_EOL);
 356
 357   while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
 358     {
 359       SCM new_tail;
 360
 361       scm_ungetc (c, port);
 362       if (scm_is_eq (scm_sym_dot,
 363                      (tmp = scm_read_expression (port))))
 364         {
 365           SCM_SETCDR (tl, tmp = scm_read_expression (port));
 366
 367           if (SCM_COPY_SOURCE_P)
 368             SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
 369                                        SCM_EOL));
 370
 371           c = flush_ws (port, FUNC_NAME);
 372           if (terminating_char != c)
 373             scm_i_input_error (FUNC_NAME, port,
 374                                "in pair: missing close paren", SCM_EOL);
 375           goto exit;
 376         }
 377
 378       new_tail = scm_cons (tmp, SCM_EOL);
 379       SCM_SETCDR (tl, new_tail);
 380       tl = new_tail;
 381
 382       if (SCM_COPY_SOURCE_P)
 383         {
 384           SCM new_tail2 = scm_cons (scm_is_pair (tmp)
 385                                     ? copy
 386                                     : tmp, SCM_EOL);
 387           SCM_SETCDR (tl2, new_tail2);
 388           tl2 = new_tail2;
 389         }
 390     }
 391
 392  exit:
 393   if (SCM_RECORD_POSITIONS_P)
 394     scm_whash_insert (scm_source_whash,
 395                       ans,
 396                       scm_make_srcprops (line, column,
 397                                          SCM_FILENAME (port),
 398                                          SCM_COPY_SOURCE_P
 399                                          ? ans2
 400                                          : SCM_UNDEFINED,
 401                                          SCM_EOL));
 402   return ans;
 403 }
 404 #undef FUNC_NAME
 405
 406 static SCM
 407 scm_read_string (int chr, SCM port)
 408 #define FUNC_NAME "scm_lreadr"
 409 {
 410   /* For strings smaller than C_STR, this function creates only one Scheme
 411      object (the string returned).  */
 412
 413   SCM str = SCM_BOOL_F;
 414   char c_str[READER_STRING_BUFFER_SIZE];
 415   unsigned c_str_len = 0;
 416   int c;
 417
 418   while ('"' != (c = scm_getc (port)))
 419     {
 420       if (c == EOF)
 421         str_eof: scm_i_input_error (FUNC_NAME, port,
 422                                     "end of file in string constant",
 423                                     SCM_EOL);
 424
 425       if (c_str_len + 1 >= sizeof (c_str))
 426         {
 427           /* Flush the C buffer onto a Scheme string.  */
 428           SCM addy;
 429
 430           if (str == SCM_BOOL_F)
 431             str = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
 432
 433           addy = scm_from_locale_stringn (c_str, c_str_len);
 434           str = scm_string_append_shared (scm_list_2 (str, addy));
 435
 436           c_str_len = 0;
 437         }
 438
 439       if (c == '\\')
 440         switch (c = scm_getc (port))
 441           {
 442           case EOF:
 443             goto str_eof;
 444           case '"':
 445           case '\\':
 446             break;
 447 #if SCM_ENABLE_ELISP
 448           case '(':
 449           case ')':
 450             if (SCM_ESCAPED_PARENS_P)
 451               break;
 452             goto bad_escaped;
 453 #endif
 454           case '\n':
 455             continue;
 456           case '0':
 457             c = '\0';
 458             break;
 459           case 'f':
 460             c = '\f';
 461             break;
 462           case 'n':
 463             c = '\n';
 464             break;
 465           case 'r':
 466             c = '\r';
 467             break;
 468           case 't':
 469             c = '\t';
 470             break;
 471           case 'a':
 472             c = '\007';
 473             break;
 474           case 'v':
 475             c = '\v';
 476             break;
 477           case 'x':
 478             {
 479               int a, b;
 480               a = scm_getc (port);
 481               if (a == EOF) goto str_eof;
 482               b = scm_getc (port);
 483               if (b == EOF) goto str_eof;
 484               if      ('0' <= a && a <= '9') a -= '0';
 485               else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
 486               else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
 487               else goto bad_escaped;
 488               if      ('0' <= b && b <= '9') b -= '0';
 489               else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
 490               else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
 491               else goto bad_escaped;
 492               c = a * 16 + b;
 493               break;
 494             }
 495           default:
 496           bad_escaped:
 497             scm_i_input_error (FUNC_NAME, port,
 498                                "illegal character in escape sequence: ~S",
 499                                scm_list_1 (SCM_MAKE_CHAR (c)));
 500           }
 501       c_str[c_str_len++] = c;
 502     }
 503
 504   if (c_str_len > 0)
 505     {
 506       SCM addy;
 507
 508       addy = scm_from_locale_stringn (c_str, c_str_len);
 509       if (str == SCM_BOOL_F)
 510         str = addy;
 511       else
 512         str = scm_string_append_shared (scm_list_2 (str, addy));
 513     }
 514   else
 515     str = (str == SCM_BOOL_F) ? scm_nullstr : str;
 516
 517   return str;
 518 }
 519 #undef FUNC_NAME
 520
 521
 522 static SCM
 523 scm_read_number (int chr, SCM port)
 524 {
 525   SCM result, str = SCM_EOL;
 526   char buffer[READER_BUFFER_SIZE];
 527   size_t read;
 528   int overflow = 0;
 529
 530   scm_ungetc (chr, port);
 531   do
 532     {
 533       overflow = read_token (port, buffer, sizeof (buffer), &read);
 534
 535       if ((overflow) || (scm_is_pair (str)))
 536         str = scm_cons (scm_from_locale_stringn (buffer, read), str);
 537     }
 538   while (overflow);
 539
 540   if (scm_is_pair (str))
 541     {
 542       /* The slow path.  */
 543
 544       str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
 545       result = scm_string_to_number (str, SCM_UNDEFINED);
 546       if (!scm_is_true (result))
 547         /* Return a symbol instead of a number.  */
 548         result = scm_string_to_symbol (str);
 549     }
 550   else
 551     {
 552       result = scm_c_locale_stringn_to_number (buffer, read, 10);
 553       if (!scm_is_true (result))
 554         /* Return a symbol instead of a number.  */
 555         result = scm_from_locale_symboln (buffer, read);
 556     }
 557
 558   return result;
 559 }
 560
 561 static SCM
 562 scm_read_mixed_case_symbol (int chr, SCM port)
 563 {
 564   SCM result, str = SCM_EOL;
 565   int overflow = 0, ends_with_colon = 0;
 566   char buffer[READER_BUFFER_SIZE];
 567   size_t read = 0;
 568   int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
 569
 570   scm_ungetc (chr, port);
 571   do
 572     {
 573       overflow = read_token (port, buffer, sizeof (buffer), &read);
 574
 575       if (read > 0)
 576         ends_with_colon = (buffer[read - 1] == ':');
 577
 578       if ((overflow) || (scm_is_pair (str)))
 579         str = scm_cons (scm_from_locale_stringn (buffer, read), str);
 580     }
 581   while (overflow);
 582
 583   if (scm_is_pair (str))
 584     {
 585       size_t len;
 586
 587       str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
 588       len = scm_c_string_length (str);
 589
 590       /* Per SRFI-88, `:' alone is an identifier, not a keyword.  */
 591       if (postfix && ends_with_colon && (len > 1))
 592         {
 593           /* Strip off colon.  */
 594           str = scm_c_substring (str, 0, len-1);
 595           result = scm_string_to_symbol (str);
 596           result = scm_symbol_to_keyword (result);
 597         }
 598       else
 599         result = scm_string_to_symbol (str);
 600     }
 601   else
 602     {
 603       /* For symbols smaller than `sizeof (buffer)', we don't need to recur
 604          to Scheme strings.  Therefore, we only create one Scheme object (a
 605          symbol) per symbol read.  */
 606       if (postfix && ends_with_colon && (read > 1))
 607         result = scm_from_locale_keywordn (buffer, read - 1);
 608       else
 609         result = scm_from_locale_symboln (buffer, read);
 610     }
 611
 612   return result;
 613 }
 614
 615 static SCM
 616 scm_read_number_and_radix (int chr, SCM port)
 617 #define FUNC_NAME "scm_lreadr"
 618 {
 619   SCM result, str = SCM_EOL;
 620   size_t read;
 621   char buffer[READER_BUFFER_SIZE];
 622   unsigned int radix;
 623   int overflow = 0;
 624
 625   switch (chr)
 626     {
 627     case 'B':
 628     case 'b':
 629       radix = 2;
 630       break;
 631
 632     case 'o':
 633     case 'O':
 634       radix = 8;
 635       break;
 636
 637     case 'd':
 638     case 'D':
 639       radix = 10;
 640       break;
 641
 642     case 'x':
 643     case 'X':
 644       radix = 16;
 645       break;
 646
 647     default:
 648       scm_ungetc (chr, port);
 649       scm_ungetc ('#', port);
 650       radix = 10;
 651     }
 652
 653   do
 654     {
 655       overflow = read_token (port, buffer, sizeof (buffer), &read);
 656
 657       if ((overflow) || (scm_is_pair (str)))
 658         str = scm_cons (scm_from_locale_stringn (buffer, read), str);
 659     }
 660   while (overflow);
 661
 662   if (scm_is_pair (str))
 663     {
 664       str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
 665       result = scm_string_to_number (str, scm_from_uint (radix));
 666     }
 667   else
 668     result = scm_c_locale_stringn_to_number (buffer, read, radix);
 669
 670   if (scm_is_true (result))
 671     return result;
 672
 673   scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
 674
 675   return SCM_BOOL_F;
 676 }
 677 #undef FUNC_NAME
 678
 679 static SCM
 680 scm_read_quote (int chr, SCM port)
 681 {
 682   SCM p;
 683   long line = SCM_LINUM (port);
 684   int column = SCM_COL (port) - 1;
 685
 686   switch (chr)
 687     {
 688     case '`':
 689       p = scm_sym_quasiquote;
 690       break;
 691
 692     case '\'':
 693       p = scm_sym_quote;
 694       break;
 695
 696     case ',':
 697       {
 698         int c;
 699
 700         c = scm_getc (port);
 701         if ('@' == c)
 702           p = scm_sym_uq_splicing;
 703         else
 704           {
 705             scm_ungetc (c, port);
 706             p = scm_sym_unquote;
 707           }
 708         break;
 709       }
 710
 711     default:
 712       fprintf (stderr, "%s: unhandled quote character (%i)\n",
 713                "scm_read_quote", chr);
 714       abort ();
 715     }
 716
 717   p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
 718   if (SCM_RECORD_POSITIONS_P)
 719     scm_whash_insert (scm_source_whash, p,
 720                       scm_make_srcprops (line, column,
 721                                          SCM_FILENAME (port),
 722                                          SCM_COPY_SOURCE_P
 723                                          ? (scm_cons2 (SCM_CAR (p),
 724                                                        SCM_CAR (SCM_CDR (p)),
 725                                                        SCM_EOL))
 726                                          : SCM_UNDEFINED,
 727                                          SCM_EOL));
 728
 729
 730   return p;
 731 }
 732
 733 static inline SCM
 734 scm_read_semicolon_comment (int chr, SCM port)
 735 {
 736   int c;
 737
 738   for (c = scm_getc (port);
 739        (c != EOF) && (c != '\n');
 740        c = scm_getc (port));
 741
 742   return SCM_UNSPECIFIED;
 743 }
 744
 745 \f
 746 /* Sharp readers, i.e. readers called after a `#' sign has been read.  */
 747
 748 static SCM
 749 scm_read_boolean (int chr, SCM port)
 750 {
 751   switch (chr)
 752     {
 753     case 't':
 754     case 'T':
 755       return SCM_BOOL_T;
 756
 757     case 'f':
 758     case 'F':
 759       return SCM_BOOL_F;
 760     }
 761
 762   return SCM_UNSPECIFIED;
 763 }
 764
 765 static SCM
 766 scm_read_character (int chr, SCM port)
 767 #define FUNC_NAME "scm_lreadr"
 768 {
 769   unsigned c;
 770   char charname[READER_CHAR_NAME_MAX_SIZE];
 771   size_t charname_len;
 772
 773   if (read_token (port, charname, sizeof (charname), &charname_len))
 774     goto char_error;
 775
 776   if (charname_len == 0)
 777     {
 778       chr = scm_getc (port);
 779       if (chr == EOF)
 780         scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
 781                            "while reading character", SCM_EOL);
 782
 783       /* CHR must be a token delimiter, like a whitespace.  */
 784       return (SCM_MAKE_CHAR (chr));
 785     }
 786
 787   if (charname_len == 1)
 788     return SCM_MAKE_CHAR (charname[0]);
 789
 790   if (*charname >= '0' && *charname < '8')
 791     {
 792       /* Dirk:FIXME::  This type of character syntax is not R5RS
 793        * compliant.  Further, it should be verified that the constant
 794        * does only consist of octal digits.  Finally, it should be
 795        * checked whether the resulting fixnum is in the range of
 796        * characters.  */
 797       SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8);
 798       if (SCM_I_INUMP (p))
 799         return SCM_MAKE_CHAR (SCM_I_INUM (p));
 800     }
 801
 802   for (c = 0; c < scm_n_charnames; c++)
 803     if (scm_charnames[c]
 804         && (!strncasecmp (scm_charnames[c], charname, charname_len)))
 805       return SCM_MAKE_CHAR (scm_charnums[c]);
 806
 807  char_error:
 808   scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
 809                      scm_list_1 (scm_from_locale_stringn (charname,
 810                                                           charname_len)));
 811
 812   return SCM_UNSPECIFIED;
 813 }
 814 #undef FUNC_NAME
 815
 816 static inline SCM
 817 scm_read_keyword (int chr, SCM port)
 818 {
 819   SCM symbol;
 820
 821   /* Read the symbol that comprises the keyword.  Doing this instead of
 822      invoking a specific symbol reader function allows `scm_read_keyword ()'
 823      to adapt to the delimiters currently valid of symbols.
 824
 825      XXX: This implementation allows sloppy syntaxes like `#:  key'.  */
 826   symbol = scm_read_expression (port);
 827   if (!scm_is_symbol (symbol))
 828     scm_i_input_error ("scm_read_keyword", port,
 829                        "keyword prefix `~a' not followed by a symbol: ~s",
 830                        scm_list_2 (SCM_MAKE_CHAR (chr), symbol));
 831
 832   return (scm_symbol_to_keyword (symbol));
 833 }
 834
 835 static inline SCM
 836 scm_read_vector (int chr, SCM port)
 837 {
 838   /* Note: We call `scm_read_sexp ()' rather than READER here in order to
 839      guarantee that it's going to do what we want.  After all, this is an
 840      implementation detail of `scm_read_vector ()', not a desirable
 841      property.  */
 842   return (scm_vector (scm_read_sexp (chr, port)));
 843 }
 844
 845 static inline SCM
 846 scm_read_srfi4_vector (int chr, SCM port)
 847 {
 848   return scm_i_read_array (port, chr);
 849 }
 850
 851 static SCM
 852 scm_read_guile_bit_vector (int chr, SCM port)
 853 {
 854   /* Read the `#*10101'-style read syntax for bit vectors in Guile.  This is
 855      terribly inefficient but who cares?  */
 856   SCM s_bits = SCM_EOL;
 857
 858   for (chr = scm_getc (port);
 859        (chr != EOF) && ((chr == '0') || (chr == '1'));
 860        chr = scm_getc (port))
 861     {
 862       s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
 863     }
 864
 865   if (chr != EOF)
 866     scm_ungetc (chr, port);
 867
 868   return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
 869 }
 870
 871 static inline SCM
 872 scm_read_scsh_block_comment (int chr, SCM port)
 873 {
 874   int bang_seen = 0;
 875
 876   for (;;)
 877     {
 878       int c = scm_getc (port);
 879
 880       if (c == EOF)
 881         scm_i_input_error ("skip_block_comment", port,
 882                            "unterminated `#! ... !#' comment", SCM_EOL);
 883
 884       if (c == '!')
 885         bang_seen = 1;
 886       else if (c == '#' && bang_seen)
 887         break;
 888       else
 889         bang_seen = 0;
 890     }
 891
 892   return SCM_UNSPECIFIED;
 893 }
 894
 895 static SCM
 896 scm_read_extended_symbol (int chr, SCM port)
 897 {
 898   /* Guile's extended symbol read syntax looks like this:
 899
 900        #{This is all a symbol name}#
 901
 902      So here, CHR is expected to be `{'.  */
 903   SCM result;
 904   int saw_brace = 0, finished = 0;
 905   size_t len = 0;
 906   char buf[1024];
 907
 908   result = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
 909
 910   while ((chr = scm_getc (port)) != EOF)
 911     {
 912       if (saw_brace)
 913         {
 914           if (chr == '#')
 915             {
 916               finished = 1;
 917               break;
 918             }
 919           else
 920             {
 921               saw_brace = 0;
 922               buf[len++] = '}';
 923               buf[len++] = chr;
 924             }
 925         }
 926       else if (chr == '}')
 927         saw_brace = 1;
 928       else
 929         buf[len++] = chr;
 930
 931       if (len >= sizeof (buf) - 2)
 932         {
 933           scm_string_append (scm_list_2 (result,
 934                                          scm_from_locale_stringn (buf, len)));
 935           len = 0;
 936         }
 937
 938       if (finished)
 939         break;
 940     }
 941
 942   if (len)
 943     result = scm_string_append (scm_list_2
 944                                 (result,
 945                                  scm_from_locale_stringn (buf, len)));
 946
 947   return (scm_string_to_symbol (result));
 948 }
 949
 950
 951 \f
 952 /* Top-level token readers, i.e., dispatchers.  */
 953
 954 static SCM
 955 scm_read_sharp_extension (int chr, SCM port)
 956 {
 957   SCM proc;
 958
 959   proc = scm_get_hash_procedure (chr);
 960   if (scm_is_true (scm_procedure_p (proc)))
 961     {
 962       long line = SCM_LINUM (port);
 963       int column = SCM_COL (port) - 2;
 964       SCM got;
 965
 966       got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
 967       if (!scm_is_eq (got, SCM_UNSPECIFIED))
 968         {
 969           if (SCM_RECORD_POSITIONS_P)
 970             return (recsexpr (got, line, column,
 971                               SCM_FILENAME (port)));
 972           else
 973             return got;
 974         }
 975     }
 976
 977   return SCM_UNSPECIFIED;
 978 }
 979
 980 /* The reader for the sharp `#' character.  It basically dispatches reads
 981    among the above token readers.   */
 982 static SCM
 983 scm_read_sharp (int chr, SCM port)
 984 #define FUNC_NAME "scm_lreadr"
 985 {
 986   SCM result;
 987
 988   chr = scm_getc (port);
 989
 990   result = scm_read_sharp_extension (chr, port);
 991   if (!scm_is_eq (result, SCM_UNSPECIFIED))
 992     return result;
 993
 994   switch (chr)
 995     {
 996     case '\\':
 997       return (scm_read_character (chr, port));
 998     case '(':
 999       return (scm_read_vector (chr, port));
1000     case 's':
1001     case 'u':
1002     case 'f':
1003       /* This one may return either a boolean or an SRFI-4 vector.  */
1004       return (scm_read_srfi4_vector (chr, port));
1005     case '*':
1006       return (scm_read_guile_bit_vector (chr, port));
1007     case 't':
1008     case 'T':
1009     case 'F':
1010       /* This one may return either a boolean or an SRFI-4 vector.  */
1011       return (scm_read_boolean (chr, port));
1012     case ':':
1013       return (scm_read_keyword (chr, port));
1014     case '0': case '1': case '2': case '3': case '4':
1015     case '5': case '6': case '7': case '8': case '9':
1016     case '@':
1017 #if SCM_ENABLE_DEPRECATED
1018       /* See below for 'i' and 'e'. */
1019     case 'a':
1020     case 'c':
1021     case 'y':
1022     case 'h':
1023     case 'l':
1024 #endif
1025       return (scm_i_read_array (port, chr));
1026
1027     case 'i':
1028     case 'e':
1029 #if SCM_ENABLE_DEPRECATED
1030       {
1031         /* When next char is '(', it really is an old-style
1032            uniform array. */
1033         int next_c = scm_getc (port);
1034         if (next_c != EOF)
1035           scm_ungetc (next_c, port);
1036         if (next_c == '(')
1037           return scm_i_read_array (port, chr);
1038         /* Fall through. */
1039       }
1040 #endif
1041     case 'b':
1042     case 'B':
1043     case 'o':
1044     case 'O':
1045     case 'd':
1046     case 'D':
1047     case 'x':
1048     case 'X':
1049     case 'I':
1050     case 'E':
1051       return (scm_read_number_and_radix (chr, port));
1052     case '{':
1053       return (scm_read_extended_symbol (chr, port));
1054     case '!':
1055       return (scm_read_scsh_block_comment (chr, port));
1056     default:
1057       result = scm_read_sharp_extension (chr, port);
1058       if (scm_is_eq (result, SCM_UNSPECIFIED))
1059         scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
1060                            scm_list_1 (SCM_MAKE_CHAR (chr)));
1061       else
1062         return result;
1063     }
1064
1065   return SCM_UNSPECIFIED;
1066 }
1067 #undef FUNC_NAME
1068
1069 static SCM
1070 scm_read_expression (SCM port)
1071 #define FUNC_NAME "scm_read_expression"
1072 {
1073   while (1)
1074     {
1075       register int chr;
1076
1077       chr = scm_getc (port);
1078
1079       switch (chr)
1080         {
1081         case SCM_WHITE_SPACES:
1082         case SCM_LINE_INCREMENTORS:
1083           break;
1084         case ';':
1085           (void) scm_read_semicolon_comment (chr, port);
1086           break;
1087         case '(':
1088           return (scm_read_sexp (chr, port));
1089         case '"':
1090           return (scm_read_string (chr, port));
1091         case '\'':
1092         case '`':
1093         case ',':
1094           return (scm_read_quote (chr, port));
1095         case '#':
1096           {
1097             SCM result;
1098             result = scm_read_sharp (chr, port);
1099             if (scm_is_eq (result, SCM_UNSPECIFIED))
1100               /* We read a comment or some such.  */
1101               break;
1102             else
1103               return result;
1104           }
1105         case ')':
1106           scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
1107           break;
1108         case EOF:
1109           return SCM_EOF_VAL;
1110         case ':':
1111           if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
1112             return scm_symbol_to_keyword (scm_read_expression (port));
1113           /* Fall through.  */
1114
1115         default:
1116           {
1117             if (((chr >= '0') && (chr <= '9'))
1118                 || (strchr ("+-.", chr)))
1119               return (scm_read_number (chr, port));
1120             else
1121               return (scm_read_mixed_case_symbol (chr, port));
1122           }
1123         }
1124     }
1125 }
1126 #undef FUNC_NAME
1127
1128 \f
1129 /* Actual reader.  */
1130
1131 SCM_DEFINE (scm_read, "read", 0, 1, 0,
1132             (SCM port),
1133             "Read an s-expression from the input port @var{port}, or from\n"
1134             "the current input port if @var{port} is not specified.\n"
1135             "Any whitespace before the next token is discarded.")
1136 #define FUNC_NAME s_scm_read
1137 {
1138   int c;
1139
1140   if (SCM_UNBNDP (port))
1141     port = scm_current_input_port ();
1142   SCM_VALIDATE_OPINPORT (1, port);
1143
1144   c = flush_ws (port, (char *) NULL);
1145   if (EOF == c)
1146     return SCM_EOF_VAL;
1147   scm_ungetc (c, port);
1148
1149   return (scm_read_expression (port));
1150 }
1151 #undef FUNC_NAME
1152
1153
1154 \f
1155
1156 /* Used when recording expressions constructed by `scm_read_sharp ()'.  */
1157 static SCM
1158 recsexpr (SCM obj, long line, int column, SCM filename)
1159 {
1160   if (!scm_is_pair(obj)) {
1161     return obj;
1162   } else {
1163     SCM tmp = obj, copy;
1164     /* If this sexpr is visible in the read:sharp source, we want to
1165        keep that information, so only record non-constant cons cells
1166        which haven't previously been read by the reader. */
1167     if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
1168       {
1169         if (SCM_COPY_SOURCE_P)
1170           {
1171             copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
1172                              SCM_UNDEFINED);
1173             while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
1174               {
1175                 SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
1176                                                       line,
1177                                                       column,
1178                                                       filename),
1179                                             SCM_UNDEFINED));
1180                 copy = SCM_CDR (copy);
1181               }
1182             SCM_SETCDR (copy, tmp);
1183           }
1184         else
1185           {
1186             recsexpr (SCM_CAR (obj), line, column, filename);
1187             while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
1188               recsexpr (SCM_CAR (tmp), line, column, filename);
1189             copy = SCM_UNDEFINED;
1190           }
1191         scm_whash_insert (scm_source_whash,
1192                           obj,
1193                           scm_make_srcprops (line,
1194                                              column,
1195                                              filename,
1196                                              copy,
1197                                              SCM_EOL));
1198       }
1199     return obj;
1200   }
1201 }
1202
1203 /* Manipulate the read-hash-procedures alist.  This could be written in
1204    Scheme, but maybe it will also be used by C code during initialisation.  */
1205 SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
1206             (SCM chr, SCM proc),
1207             "Install the procedure @var{proc} for reading expressions\n"
1208             "starting with the character sequence @code{#} and @var{chr}.\n"
1209             "@var{proc} will be called with two arguments:  the character\n"
1210             "@var{chr} and the port to read further data from. The object\n"
1211             "returned will be the return value of @code{read}.")
1212 #define FUNC_NAME s_scm_read_hash_extend
1213 {
1214   SCM this;
1215   SCM prev;
1216
1217   SCM_VALIDATE_CHAR (1, chr);
1218   SCM_ASSERT (scm_is_false (proc)
1219               || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
1220               proc, SCM_ARG2, FUNC_NAME);
1221
1222   /* Check if chr is already in the alist.  */
1223   this = *scm_read_hash_procedures;
1224   prev = SCM_BOOL_F;
1225   while (1)
1226     {
1227       if (scm_is_null (this))
1228         {
1229           /* not found, so add it to the beginning.  */
1230           if (scm_is_true (proc))
1231             {
1232               *scm_read_hash_procedures =
1233                 scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
1234             }
1235           break;
1236         }
1237       if (scm_is_eq (chr, SCM_CAAR (this)))
1238         {
1239           /* already in the alist.  */
1240           if (scm_is_false (proc))
1241             {
1242               /* remove it.  */
1243               if (scm_is_false (prev))
1244                 {
1245                   *scm_read_hash_procedures =
1246                     SCM_CDR (*scm_read_hash_procedures);
1247                 }
1248               else
1249                 scm_set_cdr_x (prev, SCM_CDR (this));
1250             }
1251           else
1252             {
1253               /* replace it.  */
1254               scm_set_cdr_x (SCM_CAR (this), proc);
1255             }
1256           break;
1257         }
1258       prev = this;
1259       this = SCM_CDR (this);
1260     }
1261
1262   return SCM_UNSPECIFIED;
1263 }
1264 #undef FUNC_NAME
1265
1266 /* Recover the read-hash procedure corresponding to char c.  */
1267 static SCM
1268 scm_get_hash_procedure (int c)
1269 {
1270   SCM rest = *scm_read_hash_procedures;
1271
1272   while (1)
1273     {
1274       if (scm_is_null (rest))
1275         return SCM_BOOL_F;
1276
1277       if (SCM_CHAR (SCM_CAAR (rest)) == c)
1278         return SCM_CDAR (rest);
1279
1280       rest = SCM_CDR (rest);
1281     }
1282 }
1283
1284 void
1285 scm_init_read ()
1286 {
1287   scm_read_hash_procedures =
1288     SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
1289
1290   scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
1291 #include "libguile/read.x"
1292 }
1293
1294 /*
1295   Local Variables:
1296   c-file-style: "gnu"
1297   End:
1298 */