libguile/read.c

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