libguile/read.c

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