libguile/read.c

   1 /* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007 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 #include <stdio.h>
  23 #include "libguile/_scm.h"
  24 #include "libguile/chars.h"
  25 #include "libguile/eval.h"
  26 #include "libguile/unif.h"
  27 #include "libguile/keywords.h"
  28 #include "libguile/alist.h"
  29 #include "libguile/srcprop.h"
  30 #include "libguile/hashtab.h"
  31 #include "libguile/hash.h"
  32 #include "libguile/ports.h"
  33 #include "libguile/root.h"
  34 #include "libguile/strings.h"
  35 #include "libguile/strports.h"
  36 #include "libguile/vectors.h"
  37 #include "libguile/validate.h"
  38 #include "libguile/srfi-4.h"
  39
  40 #include "libguile/read.h"
  41 #include "libguile/private-options.h"
  42
  43
  44 \f
  45
  46 SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
  47 SCM_SYMBOL (scm_keyword_prefix, "prefix");
  48
  49 scm_t_option scm_read_opts[] = {
  50   { SCM_OPTION_BOOLEAN, "copy", 0,
  51     "Copy source code expressions." },
  52   { SCM_OPTION_BOOLEAN, "positions", 0,
  53     "Record positions of source code expressions." },
  54   { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
  55     "Convert symbols to lower case."},
  56   { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
  57     "Style of keyword recognition: #f or 'prefix."},
  58 #if SCM_ENABLE_ELISP
  59   { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
  60     "Support Elisp vector syntax, namely `[...]'."},
  61   { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
  62     "Support `\\(' and `\\)' in strings."},
  63 #endif
  64   { 0, },
  65 };
  66
  67 /*
  68   Give meaningful error messages for errors
  69
  70   We use the format
  71
  72   FILE:LINE:COL: MESSAGE
  73   This happened in ....
  74
  75   This is not standard GNU format, but the test-suite likes the real
  76   message to be in front.
  77
  78  */
  79
  80
  81 void
  82 scm_i_input_error (char const *function,
  83                    SCM port, const char *message, SCM arg)
  84 {
  85   SCM fn = (scm_is_string (SCM_FILENAME(port))
  86             ? SCM_FILENAME(port)
  87             : scm_from_locale_string ("#<unknown port>"));
  88
  89   SCM string_port = scm_open_output_string ();
  90   SCM string = SCM_EOL;
  91   scm_simple_format (string_port,
  92                      scm_from_locale_string ("~A:~S:~S: ~A"),
  93                      scm_list_4 (fn,
  94                                  scm_from_long (SCM_LINUM (port) + 1),
  95                                  scm_from_int (SCM_COL (port) + 1),
  96                                  scm_from_locale_string (message)));
  97
  98   string = scm_get_output_string (string_port);
  99   scm_close_output_port (string_port);
 100   scm_error_scm (scm_from_locale_symbol ("read-error"),
 101                  function? scm_from_locale_string (function) : SCM_BOOL_F,
 102                  string,
 103                  arg,
 104                  SCM_BOOL_F);
 105 }
 106
 107
 108 SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
 109             (SCM setting),
 110             "Option interface for the read options. Instead of using\n"
 111             "this procedure directly, use the procedures @code{read-enable},\n"
 112             "@code{read-disable}, @code{read-set!} and @code{read-options}.")
 113 #define FUNC_NAME s_scm_read_options
 114 {
 115   SCM ans = scm_options (setting,
 116                          scm_read_opts,
 117                          FUNC_NAME);
 118   if (SCM_COPY_SOURCE_P)
 119     SCM_RECORD_POSITIONS_P = 1;
 120   return ans;
 121 }
 122 #undef FUNC_NAME
 123
 124 /* An association list mapping extra hash characters to procedures.  */
 125 static SCM *scm_read_hash_procedures;
 126
 127 SCM_DEFINE (scm_read, "read", 0, 1, 0,
 128             (SCM port),
 129             "Read an s-expression from the input port @var{port}, or from\n"
 130             "the current input port if @var{port} is not specified.\n"
 131             "Any whitespace before the next token is discarded.")
 132 #define FUNC_NAME s_scm_read
 133 {
 134   int c;
 135   SCM tok_buf, copy;
 136
 137   if (SCM_UNBNDP (port))
 138     port = scm_current_input_port ();
 139   SCM_VALIDATE_OPINPORT (1, port);
 140
 141   c = scm_flush_ws (port, (char *) NULL);
 142   if (EOF == c)
 143     return SCM_EOF_VAL;
 144   scm_ungetc (c, port);
 145
 146   tok_buf = scm_c_make_string (30, SCM_UNDEFINED);
 147   return scm_lreadr (&tok_buf, port, &copy);
 148 }
 149 #undef FUNC_NAME
 150
 151
 152
 153 char *
 154 scm_grow_tok_buf (SCM *tok_buf)
 155 {
 156   size_t oldlen = scm_i_string_length (*tok_buf);
 157   const char *olddata = scm_i_string_chars (*tok_buf);
 158   char *newdata;
 159   SCM newstr = scm_i_make_string (2 * oldlen, &newdata);
 160   size_t i;
 161
 162   for (i = 0; i != oldlen; ++i)
 163     newdata[i] = olddata[i];
 164
 165   *tok_buf = newstr;
 166   return newdata;
 167 }
 168
 169 /* Consume an SCSH-style block comment.  Assume that we've already
 170    read the initial `#!', and eat characters until we get a
 171    exclamation-point/sharp-sign sequence.
 172 */
 173
 174 static void
 175 skip_scsh_block_comment (SCM port)
 176 {
 177   int bang_seen = 0;
 178
 179   for (;;)
 180     {
 181       int c = scm_getc (port);
 182
 183       if (c == EOF)
 184         scm_i_input_error ("skip_block_comment", port,
 185                            "unterminated `#! ... !#' comment", SCM_EOL);
 186
 187       if (c == '!')
 188         bang_seen = 1;
 189       else if (c == '#' && bang_seen)
 190         return;
 191       else
 192         bang_seen = 0;
 193     }
 194 }
 195
 196 int
 197 scm_flush_ws (SCM port, const char *eoferr)
 198 {
 199   register int c;
 200   while (1)
 201     switch (c = scm_getc (port))
 202       {
 203       case EOF:
 204       goteof:
 205         if (eoferr)
 206           {
 207             scm_i_input_error (eoferr,
 208                                port,
 209                                "end of file",
 210                                SCM_EOL);
 211           }
 212         return c;
 213       case ';':
 214       lp:
 215         switch (c = scm_getc (port))
 216           {
 217           case EOF:
 218             goto goteof;
 219           default:
 220             goto lp;
 221           case SCM_LINE_INCREMENTORS:
 222             break;
 223           }
 224         break;
 225       case '#':
 226         switch (c = scm_getc (port))
 227           {
 228           case EOF:
 229             eoferr = "read_sharp";
 230             goto goteof;
 231           case '!':
 232             skip_scsh_block_comment (port);
 233             break;
 234           default:
 235             scm_ungetc (c, port);
 236             return '#';
 237           }
 238         break;
 239       case SCM_LINE_INCREMENTORS:
 240       case SCM_SINGLE_SPACES:
 241       case '\t':
 242         break;
 243       default:
 244         return c;
 245       }
 246 }
 247
 248
 249
 250 int
 251 scm_casei_streq (char *s1, char *s2)
 252 {
 253   while (*s1 && *s2)
 254     if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2))
 255       return 0;
 256     else
 257       {
 258         ++s1;
 259         ++s2;
 260       }
 261   return !(*s1 || *s2);
 262 }
 263
 264 static int
 265 scm_i_casei_streq (const char *s1, const char *s2, size_t len2)
 266 {
 267   while (*s1 && len2 > 0)
 268     if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2))
 269       return 0;
 270     else
 271       {
 272         ++s1;
 273         ++s2;
 274         --len2;
 275       }
 276   return !(*s1 || len2 > 0);
 277 }
 278
 279 /* recsexpr is used when recording expressions
 280  * constructed by read:sharp.
 281  */
 282 static SCM
 283 recsexpr (SCM obj, long line, int column, SCM filename)
 284 {
 285   if (!scm_is_pair(obj)) {
 286     return obj;
 287   } else {
 288     SCM tmp = obj, copy;
 289     /* If this sexpr is visible in the read:sharp source, we want to
 290        keep that information, so only record non-constant cons cells
 291        which haven't previously been read by the reader. */
 292     if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
 293       {
 294         if (SCM_COPY_SOURCE_P)
 295           {
 296             copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
 297                              SCM_UNDEFINED);
 298             while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
 299               {
 300                 SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
 301                                                       line,
 302                                                       column,
 303                                                       filename),
 304                                             SCM_UNDEFINED));
 305                 copy = SCM_CDR (copy);
 306               }
 307             SCM_SETCDR (copy, tmp);
 308           }
 309         else
 310           {
 311             recsexpr (SCM_CAR (obj), line, column, filename);
 312             while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
 313               recsexpr (SCM_CAR (tmp), line, column, filename);
 314             copy = SCM_UNDEFINED;
 315           }
 316         scm_whash_insert (scm_source_whash,
 317                           obj,
 318                           scm_make_srcprops (line,
 319                                              column,
 320                                              filename,
 321                                              copy,
 322                                              SCM_EOL));
 323       }
 324     return obj;
 325   }
 326 }
 327
 328
 329 static SCM scm_get_hash_procedure(int c);
 330 static SCM scm_i_lreadparen (SCM *, SCM, char *, SCM *, char);
 331
 332 static char s_list[]="list";
 333 #if SCM_ENABLE_ELISP
 334 static char s_vector[]="vector";
 335 #endif
 336
 337 SCM
 338 scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
 339 #define FUNC_NAME "scm_lreadr"
 340 {
 341   int c;
 342   size_t j;
 343   SCM p;
 344
 345  tryagain:
 346   c = scm_flush_ws (port, s_scm_read);
 347   switch (c)
 348     {
 349     case EOF:
 350       return SCM_EOF_VAL;
 351
 352     case '(':
 353       return SCM_RECORD_POSITIONS_P
 354         ? scm_lreadrecparen (tok_buf, port, s_list, copy)
 355         : scm_i_lreadparen (tok_buf, port, s_list, copy, ')');
 356     case ')':
 357       scm_i_input_error (FUNC_NAME, port,"unexpected \")\"", SCM_EOL);
 358       goto tryagain;
 359
 360 #if SCM_ENABLE_ELISP
 361     case '[':
 362       if (SCM_ELISP_VECTORS_P)
 363         {
 364           p = scm_i_lreadparen (tok_buf, port, s_vector, copy, ']');
 365           return scm_is_null (p) ? scm_nullvect : scm_vector (p);
 366         }
 367       goto read_token;
 368 #endif
 369     case '\'':
 370       p = scm_sym_quote;
 371       goto recquote;
 372     case '`':
 373       p = scm_sym_quasiquote;
 374       goto recquote;
 375     case ',':
 376       c = scm_getc (port);
 377       if ('@' == c)
 378         p = scm_sym_uq_splicing;
 379       else
 380         {
 381           scm_ungetc (c, port);
 382           p = scm_sym_unquote;
 383         }
 384     recquote:
 385       p = scm_cons2 (p,
 386                      scm_lreadr (tok_buf, port, copy),
 387                      SCM_EOL);
 388       if (SCM_RECORD_POSITIONS_P)
 389         scm_whash_insert (scm_source_whash,
 390                           p,
 391                           scm_make_srcprops (SCM_LINUM (port),
 392                                              SCM_COL (port) - 1,
 393                                              SCM_FILENAME (port),
 394                                              SCM_COPY_SOURCE_P
 395                                              ? (*copy = scm_cons2 (SCM_CAR (p),
 396                                                                    SCM_CAR (SCM_CDR (p)),
 397                                                                    SCM_EOL))
 398                                              : SCM_UNDEFINED,
 399                                              SCM_EOL));
 400       return p;
 401     case '#':
 402       c = scm_getc (port);
 403
 404       {
 405         /* Check for user-defined hash procedure first, to allow
 406            overriding of builtin hash read syntaxes.  */
 407         SCM sharp = scm_get_hash_procedure (c);
 408         if (scm_is_true (sharp))
 409           {
 410             long line = SCM_LINUM (port);
 411             int column = SCM_COL (port) - 2;
 412             SCM got;
 413
 414             got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port);
 415             if (scm_is_eq (got, SCM_UNSPECIFIED))
 416               goto handle_sharp;
 417             if (SCM_RECORD_POSITIONS_P)
 418               return *copy = recsexpr (got, line, column,
 419                                        SCM_FILENAME (port));
 420             else
 421               return got;
 422           }
 423       }
 424     handle_sharp:
 425       switch (c)
 426         {
 427           /* Vector, arrays, both uniform and not are handled by this
 428              one function.  It also disambiguates between '#f' and
 429              '#f32' and '#f64'.
 430           */
 431         case '0': case '1': case '2': case '3': case '4':
 432         case '5': case '6': case '7': case '8': case '9':
 433         case 'u': case 's': case 'f':
 434         case '@':
 435         case '(':
 436 #if SCM_ENABLE_DEPRECATED
 437           /* See below for 'i' and 'e'. */
 438         case 'a':
 439         case 'c':
 440         case 'y':
 441         case 'h':
 442         case 'l':
 443 #endif
 444           return scm_i_read_array (port, c);
 445
 446         case 't':
 447         case 'T':
 448           return SCM_BOOL_T;
 449
 450         case 'F':
 451           /* See above for lower case 'f'. */
 452           return SCM_BOOL_F;
 453
 454
 455         case 'i':
 456         case 'e':
 457 #if SCM_ENABLE_DEPRECATED
 458           {
 459             /* When next char is '(', it really is an old-style
 460                uniform array. */
 461             int next_c = scm_getc (port);
 462             if (next_c != EOF)
 463               scm_ungetc (next_c, port);
 464             if (next_c == '(')
 465               return scm_i_read_array (port, c);
 466             /* Fall through. */
 467           }
 468 #endif
 469         case 'b':
 470         case 'B':
 471         case 'o':
 472         case 'O':
 473         case 'd':
 474         case 'D':
 475         case 'x':
 476         case 'X':
 477         case 'I':
 478         case 'E':
 479           scm_ungetc (c, port);
 480           c = '#';
 481           goto num;
 482
 483         case '!':
 484           /* should never happen, #!...!# block comments are skipped
 485              over in scm_flush_ws. */
 486           abort ();
 487
 488         case '*':
 489           j = scm_read_token (c, tok_buf, port, 0);
 490           p = scm_istr2bve (scm_c_substring_shared (*tok_buf, 1, j));
 491           if (scm_is_true (p))
 492             return p;
 493           else
 494             goto unkshrp;
 495
 496         case '{':
 497           j = scm_read_token (c, tok_buf, port, 1);
 498           return scm_string_to_symbol (scm_c_substring_copy (*tok_buf, 0, j));
 499
 500         case '\\':
 501           c = scm_getc (port);
 502           j = scm_read_token (c, tok_buf, port, 0);
 503           if (j == 1)
 504             return SCM_MAKE_CHAR (c);
 505           if (c >= '0' && c < '8')
 506             {
 507               /* Dirk:FIXME::  This type of character syntax is not R5RS
 508                * compliant.  Further, it should be verified that the constant
 509                * does only consist of octal digits.  Finally, it should be
 510                * checked whether the resulting fixnum is in the range of
 511                * characters.  */
 512               p = scm_c_locale_stringn_to_number (scm_i_string_chars (*tok_buf),
 513                                                   j, 8);
 514               if (SCM_I_INUMP (p))
 515                 return SCM_MAKE_CHAR (SCM_I_INUM (p));
 516             }
 517           for (c = 0; c < scm_n_charnames; c++)
 518             if (scm_charnames[c]
 519                 && (scm_i_casei_streq (scm_charnames[c],
 520                                        scm_i_string_chars (*tok_buf), j)))
 521               return SCM_MAKE_CHAR (scm_charnums[c]);
 522           scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
 523                              scm_list_1 (scm_c_substring (*tok_buf, 0, j)));
 524
 525           /* #:SYMBOL is a syntax for keywords supported in all contexts.  */
 526         case ':':
 527           return scm_symbol_to_keyword (scm_read (port));
 528
 529         default:
 530         callshrp:
 531           {
 532             SCM sharp = scm_get_hash_procedure (c);
 533
 534             if (scm_is_true (sharp))
 535               {
 536                 long line = SCM_LINUM (port);
 537                 int column = SCM_COL (port) - 2;
 538                 SCM got;
 539
 540                 got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port);
 541                 if (scm_is_eq (got, SCM_UNSPECIFIED))
 542                   goto unkshrp;
 543                 if (SCM_RECORD_POSITIONS_P)
 544                   return *copy = recsexpr (got, line, column,
 545                                            SCM_FILENAME (port));
 546                 else
 547                   return got;
 548               }
 549           }
 550         unkshrp:
 551         scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
 552                            scm_list_1 (SCM_MAKE_CHAR (c)));
 553         }
 554
 555     case '"':
 556       j = 0;
 557       while ('"' != (c = scm_getc (port)))
 558         {
 559           if (c == EOF)
 560             str_eof: scm_i_input_error (FUNC_NAME, port,
 561                                         "end of file in string constant",
 562                                         SCM_EOL);
 563
 564           while (j + 2 >= scm_i_string_length (*tok_buf))
 565             scm_grow_tok_buf (tok_buf);
 566
 567           if (c == '\\')
 568             switch (c = scm_getc (port))
 569               {
 570               case EOF:
 571                 goto str_eof;
 572               case '"':
 573               case '\\':
 574                 break;
 575 #if SCM_ENABLE_ELISP
 576               case '(':
 577               case ')':
 578                 if (SCM_ESCAPED_PARENS_P)
 579                   break;
 580                 goto bad_escaped;
 581 #endif
 582               case '\n':
 583                 continue;
 584               case '0':
 585                 c = '\0';
 586                 break;
 587               case 'f':
 588                 c = '\f';
 589                 break;
 590               case 'n':
 591                 c = '\n';
 592                 break;
 593               case 'r':
 594                 c = '\r';
 595                 break;
 596               case 't':
 597                 c = '\t';
 598                 break;
 599               case 'a':
 600                 c = '\007';
 601                 break;
 602               case 'v':
 603                 c = '\v';
 604                 break;
 605               case 'x':
 606                 {
 607                   int a, b;
 608                   a = scm_getc (port);
 609                   if (a == EOF) goto str_eof;
 610                   b = scm_getc (port);
 611                   if (b == EOF) goto str_eof;
 612                   if      ('0' <= a && a <= '9') a -= '0';
 613                   else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
 614                   else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
 615                   else goto bad_escaped;
 616                   if      ('0' <= b && b <= '9') b -= '0';
 617                   else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
 618                   else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
 619                   else goto bad_escaped;
 620                   c = a * 16 + b;
 621                   break;
 622                 }
 623               default:
 624               bad_escaped:
 625                 scm_i_input_error(FUNC_NAME, port,
 626                                   "illegal character in escape sequence: ~S",
 627                                   scm_list_1 (SCM_MAKE_CHAR (c)));
 628               }
 629           scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c));
 630           ++j;
 631         }
 632       if (j == 0)
 633         return scm_nullstr;
 634
 635       /* Change this to scm_c_substring_read_only when
 636          SCM_STRING_CHARS has been removed.
 637       */
 638       return scm_c_substring_copy (*tok_buf, 0, j);
 639
 640     case '0': case '1': case '2': case '3': case '4':
 641     case '5': case '6': case '7': case '8': case '9':
 642     case '.':
 643     case '-':
 644     case '+':
 645     num:
 646       j = scm_read_token (c, tok_buf, port, 0);
 647       if (j == 1 && (c == '+' || c == '-'))
 648         /* Shortcut:  Detected symbol '+ or '- */
 649         goto tok;
 650
 651       p = scm_c_locale_stringn_to_number (scm_i_string_chars (*tok_buf), j, 10);
 652       if (scm_is_true (p))
 653         return p;
 654       if (c == '#')
 655         {
 656           if ((j == 2) && (scm_getc (port) == '('))
 657             {
 658               scm_ungetc ('(', port);
 659               c = scm_i_string_chars (*tok_buf)[1];
 660               goto callshrp;
 661             }
 662           scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
 663         }
 664       goto tok;
 665
 666     case ':':
 667       if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
 668         return scm_symbol_to_keyword (scm_read (port));
 669
 670       /* fallthrough */
 671     default:
 672 #if SCM_ENABLE_ELISP
 673     read_token:
 674 #endif
 675       j = scm_read_token (c, tok_buf, port, 0);
 676       /* fallthrough */
 677
 678     tok:
 679       return scm_string_to_symbol (scm_c_substring (*tok_buf, 0, j));
 680     }
 681 }
 682 #undef FUNC_NAME
 683
 684
 685 #ifdef _UNICOS
 686 _Pragma ("noopt");              /* # pragma _CRI noopt */
 687 #endif
 688
 689 size_t
 690 scm_read_token (int ic, SCM *tok_buf, SCM port, int weird)
 691 {
 692   size_t j;
 693   int c;
 694
 695   c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(ic) : ic);
 696
 697   if (weird)
 698     j = 0;
 699   else
 700     {
 701       j = 0;
 702       while (j + 2 >= scm_i_string_length (*tok_buf))
 703         scm_grow_tok_buf (tok_buf);
 704       scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c));
 705       ++j;
 706     }
 707
 708   while (1)
 709     {
 710       while (j + 2 >= scm_i_string_length (*tok_buf))
 711         scm_grow_tok_buf (tok_buf);
 712       c = scm_getc (port);
 713       switch (c)
 714         {
 715         case '(':
 716         case ')':
 717 #if SCM_ENABLE_ELISP
 718         case '[':
 719         case ']':
 720 #endif
 721         case '"':
 722         case ';':
 723         case SCM_WHITE_SPACES:
 724         case SCM_LINE_INCREMENTORS:
 725           if (weird
 726 #if SCM_ENABLE_ELISP
 727               || ((!SCM_ELISP_VECTORS_P) && ((c == '[') || (c == ']')))
 728 #endif
 729               )
 730             goto default_case;
 731
 732           scm_ungetc (c, port);
 733         case EOF:
 734         eof_case:
 735           return j;
 736         case '\\':
 737           if (!weird)
 738             goto default_case;
 739           else
 740             {
 741               c = scm_getc (port);
 742               if (c == EOF)
 743                 goto eof_case;
 744               else
 745                 goto default_case;
 746             }
 747         case '}':
 748           if (!weird)
 749             goto default_case;
 750
 751           c = scm_getc (port);
 752           if (c == '#')
 753             {
 754               return j;
 755             }
 756           else
 757             {
 758               scm_ungetc (c, port);
 759               c = '}';
 760               goto default_case;
 761             }
 762
 763         default:
 764         default_case:
 765           {
 766             c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(c) : c);
 767             scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c));
 768             ++j;
 769           }
 770
 771         }
 772     }
 773 }
 774
 775 #ifdef _UNICOS
 776 _Pragma ("opt");                /* # pragma _CRI opt */
 777 #endif
 778
 779 static SCM
 780 scm_i_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy, char term_char)
 781 #define FUNC_NAME "scm_i_lreadparen"
 782 {
 783   SCM tmp;
 784   SCM tl;
 785   SCM ans;
 786   int c;
 787
 788   c = scm_flush_ws (port, name);
 789   if (term_char == c)
 790     return SCM_EOL;
 791   scm_ungetc (c, port);
 792   if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
 793     {
 794       ans = scm_lreadr (tok_buf, port, copy);
 795     closeit:
 796       if (term_char != (c = scm_flush_ws (port, name)))
 797         scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
 798       return ans;
 799     }
 800   ans = tl = scm_cons (tmp, SCM_EOL);
 801   while (term_char != (c = scm_flush_ws (port, name)))
 802     {
 803       scm_ungetc (c, port);
 804       if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
 805         {
 806           SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy));
 807           goto closeit;
 808         }
 809       SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
 810       tl = SCM_CDR (tl);
 811     }
 812   return ans;
 813 }
 814 #undef FUNC_NAME
 815
 816
 817 SCM
 818 scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
 819 #define FUNC_NAME "scm_lreadrecparen"
 820 {
 821   register int c;
 822   register SCM tmp;
 823   register SCM tl, tl2 = SCM_EOL;
 824   SCM ans, ans2 = SCM_EOL;
 825   /* Need to capture line and column numbers here. */
 826   long line = SCM_LINUM (port);
 827   int column = SCM_COL (port) - 1;
 828
 829   c = scm_flush_ws (port, name);
 830   if (')' == c)
 831     return SCM_EOL;
 832   scm_ungetc (c, port);
 833   if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
 834     {
 835       ans = scm_lreadr (tok_buf, port, copy);
 836       if (')' != (c = scm_flush_ws (port, name)))
 837         scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
 838       return ans;
 839     }
 840   /* Build the head of the list structure. */
 841   ans = tl = scm_cons (tmp, SCM_EOL);
 842   if (SCM_COPY_SOURCE_P)
 843     ans2 = tl2 = scm_cons (scm_is_pair (tmp)
 844                            ? *copy
 845                            : tmp,
 846                            SCM_EOL);
 847   while (')' != (c = scm_flush_ws (port, name)))
 848     {
 849       SCM new_tail;
 850
 851       scm_ungetc (c, port);
 852       if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
 853         {
 854           SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy));
 855           if (SCM_COPY_SOURCE_P)
 856             SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp)
 857                                        ? *copy
 858                                        : tmp,
 859                                        SCM_EOL));
 860           if (')' != (c = scm_flush_ws (port, name)))
 861             scm_i_input_error (FUNC_NAME, port,
 862                                "missing close paren", SCM_EOL);
 863           goto exit;
 864         }
 865
 866       new_tail = scm_cons (tmp, SCM_EOL);
 867       SCM_SETCDR (tl, new_tail);
 868       tl = new_tail;
 869
 870       if (SCM_COPY_SOURCE_P)
 871         {
 872           SCM new_tail2 = scm_cons (scm_is_pair (tmp) ? *copy : tmp, SCM_EOL);
 873           SCM_SETCDR (tl2, new_tail2);
 874           tl2 = new_tail2;
 875         }
 876     }
 877 exit:
 878   scm_whash_insert (scm_source_whash,
 879                     ans,
 880                     scm_make_srcprops (line,
 881                                        column,
 882                                        SCM_FILENAME (port),
 883                                        SCM_COPY_SOURCE_P
 884                                        ? *copy = ans2
 885                                        : SCM_UNDEFINED,
 886                                        SCM_EOL));
 887   return ans;
 888 }
 889 #undef FUNC_NAME
 890
 891
 892 \f
 893
 894 /* Manipulate the read-hash-procedures alist.  This could be written in
 895    Scheme, but maybe it will also be used by C code during initialisation.  */
 896 SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
 897             (SCM chr, SCM proc),
 898             "Install the procedure @var{proc} for reading expressions\n"
 899             "starting with the character sequence @code{#} and @var{chr}.\n"
 900             "@var{proc} will be called with two arguments:  the character\n"
 901             "@var{chr} and the port to read further data from. The object\n"
 902             "returned will be the return value of @code{read}. \n"
 903             "Passing @code{#f} for @var{proc} will remove a previous setting. \n"
 904             )
 905 #define FUNC_NAME s_scm_read_hash_extend
 906 {
 907   SCM this;
 908   SCM prev;
 909
 910   SCM_VALIDATE_CHAR (1, chr);
 911   SCM_ASSERT (scm_is_false (proc)
 912               || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
 913               proc, SCM_ARG2, FUNC_NAME);
 914
 915   /* Check if chr is already in the alist.  */
 916   this = *scm_read_hash_procedures;
 917   prev = SCM_BOOL_F;
 918   while (1)
 919     {
 920       if (scm_is_null (this))
 921         {
 922           /* not found, so add it to the beginning.  */
 923           if (scm_is_true (proc))
 924             {
 925               *scm_read_hash_procedures =
 926                 scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
 927             }
 928           break;
 929         }
 930       if (scm_is_eq (chr, SCM_CAAR (this)))
 931         {
 932           /* already in the alist.  */
 933           if (scm_is_false (proc))
 934             {
 935               /* remove it.  */
 936               if (scm_is_false (prev))
 937                 {
 938                   *scm_read_hash_procedures =
 939                     SCM_CDR (*scm_read_hash_procedures);
 940                 }
 941               else
 942                 scm_set_cdr_x (prev, SCM_CDR (this));
 943             }
 944           else
 945             {
 946               /* replace it.  */
 947               scm_set_cdr_x (SCM_CAR (this), proc);
 948             }
 949           break;
 950         }
 951       prev = this;
 952       this = SCM_CDR (this);
 953     }
 954
 955   return SCM_UNSPECIFIED;
 956 }
 957 #undef FUNC_NAME
 958
 959 /* Recover the read-hash procedure corresponding to char c.  */
 960 static SCM
 961 scm_get_hash_procedure (int c)
 962 {
 963   SCM rest = *scm_read_hash_procedures;
 964
 965   while (1)
 966     {
 967       if (scm_is_null (rest))
 968         return SCM_BOOL_F;
 969
 970       if (SCM_CHAR (SCM_CAAR (rest)) == c)
 971         return SCM_CDAR (rest);
 972
 973       rest = SCM_CDR (rest);
 974     }
 975 }
 976
 977 void
 978 scm_init_read ()
 979 {
 980   scm_read_hash_procedures =
 981     SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
 982
 983   scm_init_opts (scm_read_options, scm_read_opts);
 984 #include "libguile/read.x"
 985 }
 986
 987 /*
 988   Local Variables:
 989   c-file-style: "gnu"
 990   End:
 991 */