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