libguile/read.c

   1 /*      Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "chars.h"
  46 #include "genio.h"
  47 #include "eval.h"
  48 #include "unif.h"
  49 #include "kw.h"
  50 #include "alist.h"
  51 #include "srcprop.h"
  52 #include "hashtab.h"
  53 #include "hash.h"
  54
  55 #include "read.h"
  56
  57 \f
  58
  59 SCM_SYMBOL (scm_keyword_prefix, "prefix");
  60
  61 scm_option scm_read_opts[] = {
  62   { SCM_OPTION_BOOLEAN, "copy", 0,
  63     "Copy source code expressions." },
  64   { SCM_OPTION_BOOLEAN, "positions", 0,
  65     "Record positions of source code expressions." },
  66   { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
  67     "Convert symbols to lower case."},
  68   { SCM_OPTION_SCM, "keywords", SCM_BOOL_F,
  69     "Style of keyword recognition: #f or 'prefix"}
  70 #ifdef HAVE_RL_GETC_FUNCTION
  71   ,
  72   { SCM_OPTION_BOOLEAN, "history-file", 1,
  73     "Use history file." },
  74   { SCM_OPTION_INTEGER, "history-length", 200,
  75     "History length." }
  76 #endif /* HAVE_RL_GETC_FUNCTION */
  77 };
  78
  79 #ifdef HAVE_RL_GETC_FUNCTION
  80 extern void stifle_history (int max);
  81 #endif
  82
  83 SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options);
  84
  85 SCM
  86 scm_read_options (setting)
  87      SCM setting;
  88 {
  89   SCM ans = scm_options (setting,
  90                          scm_read_opts,
  91                          SCM_N_READ_OPTIONS,
  92                          s_read_options);
  93   if (SCM_COPY_SOURCE_P)
  94     SCM_RECORD_POSITIONS_P = 1;
  95 #ifdef HAVE_RL_GETC_FUNCTION
  96   stifle_history (SCM_HISTORY_LENGTH);
  97 #endif
  98   return ans;
  99 }
 100
 101 /* An association list mapping extra hash characters to procedures.  */
 102 static SCM *scm_read_hash_procedures;
 103
 104 SCM_PROC (s_read, "read", 0, 1, 0, scm_read);
 105
 106 SCM
 107 scm_read (port)
 108      SCM port;
 109 {
 110   int c;
 111   SCM tok_buf, copy;
 112
 113   if (SCM_UNBNDP (port))
 114     port = scm_cur_inp;
 115   else
 116     SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
 117                 port,
 118                 SCM_ARG1,
 119                 s_read);
 120
 121   c = scm_flush_ws (port, (char *) NULL);
 122   if (EOF == c)
 123     return SCM_EOF_VAL;
 124   scm_ungetc (c, port);
 125
 126   tok_buf = scm_makstr (30L, 0);
 127   return scm_lreadr (&tok_buf, port, &copy);
 128 }
 129
 130
 131
 132 char *
 133 scm_grow_tok_buf (tok_buf)
 134      SCM * tok_buf;
 135 {
 136   scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf)));
 137   return SCM_CHARS (*tok_buf);
 138 }
 139
 140
 141
 142 int
 143 scm_flush_ws (port, eoferr)
 144      SCM port;
 145      char *eoferr;
 146 {
 147   register int c;
 148   while (1)
 149     switch (c = scm_getc (port))
 150       {
 151       case EOF:
 152       goteof:
 153         if (eoferr)
 154           scm_wta (SCM_UNDEFINED, "end of file in ", eoferr);
 155         return c;
 156       case ';':
 157       lp:
 158         switch (c = scm_getc (port))
 159           {
 160           case EOF:
 161             goto goteof;
 162           default:
 163             goto lp;
 164           case SCM_LINE_INCREMENTORS:
 165             break;
 166           }
 167         break;
 168       case SCM_LINE_INCREMENTORS:
 169       case SCM_SINGLE_SPACES:
 170       case '\t':
 171         break;
 172       default:
 173         return c;
 174       }
 175 }
 176
 177
 178
 179 int
 180 scm_casei_streq (s1, s2)
 181      char * s1;
 182      char * s2;
 183 {
 184   while (*s1 && *s2)
 185     if (scm_downcase((int)*s1) != scm_downcase((int)*s2))
 186       return 0;
 187     else
 188       {
 189         ++s1;
 190         ++s2;
 191       }
 192   return !(*s1 || *s2);
 193 }
 194
 195
 196 /* recsexpr is used when recording expressions
 197  * constructed by read:sharp.
 198  */
 199 #ifndef DEBUG_EXTENSIONS
 200 #define recsexpr(obj, line, column, filename) (obj)
 201 #else
 202 static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename));
 203
 204 static SCM
 205 recsexpr (obj, line, column, filename)
 206      SCM obj;
 207      int line;
 208      int column;
 209      SCM filename;
 210 {
 211   if (SCM_IMP (obj) || SCM_NCONSP(obj))
 212     return obj;
 213   {
 214     SCM tmp = obj, copy;
 215     /* If this sexpr is visible in the read:sharp source, we want to
 216        keep that information, so only record non-constant cons cells
 217        which haven't previously been read by the reader. */
 218     if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj)))
 219       {
 220         if (SCM_COPY_SOURCE_P)
 221           {
 222             copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
 223                              SCM_UNDEFINED);
 224             while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
 225               {
 226                 SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
 227                                                       line,
 228                                                       column,
 229                                                       filename),
 230                                             SCM_UNDEFINED));
 231                 copy = SCM_CDR (copy);
 232               }
 233             SCM_SETCDR (copy, tmp);
 234           }
 235         else
 236           {
 237             recsexpr (SCM_CAR (obj), line, column, filename);
 238             while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
 239               recsexpr (SCM_CAR (tmp), line, column, filename);
 240             copy = SCM_UNDEFINED;
 241           }
 242         scm_whash_insert (scm_source_whash,
 243                           obj,
 244                           scm_make_srcprops (line,
 245                                              column,
 246                                              filename,
 247                                              copy,
 248                                              SCM_EOL));
 249       }
 250     return obj;
 251   }
 252 }
 253 #endif
 254
 255 /* Consume an SCSH-style block comment.  Assume that we've already
 256    read the initial `#!', and eat characters until we get a
 257    newline/exclamation-point/sharp-sign/newline sequence.  */
 258
 259 static void
 260 skip_scsh_block_comment (port)
 261      SCM port;
 262 {
 263   /* Is this portable?  Dear God, spare me from the non-eight-bit
 264      characters.  But is it tasteful?  */
 265   long history = 0;
 266
 267   for (;;)
 268     {
 269       int c = scm_getc (port);
 270
 271       if (c == EOF)
 272         scm_wta (SCM_UNDEFINED,
 273                  "unterminated `#! ... !#' comment", "read");
 274       history = ((history << 8) | (c & 0xff)) & 0xffffffff;
 275
 276       /* Were the last four characters read "\n!#\n"?  */
 277       if (history == (('\n' << 24) | ('!' << 16) | ('#' << 8) | '\n'))
 278         return;
 279     }
 280 }
 281
 282 static SCM
 283 scm_get_hash_procedure SCM_P ((int c));
 284
 285 static char s_list[]="list";
 286
 287 SCM
 288 scm_lreadr (tok_buf, port, copy)
 289      SCM *tok_buf;
 290      SCM port;
 291      SCM *copy;
 292 {
 293   int c;
 294   scm_sizet j;
 295   SCM p;
 296
 297 tryagain:
 298   c = scm_flush_ws (port, s_read);
 299 tryagain_no_flush_ws:
 300   switch (c)
 301     {
 302     case EOF:
 303       return SCM_EOF_VAL;
 304
 305     case '(':
 306       return SCM_RECORD_POSITIONS_P
 307              ? scm_lreadrecparen (tok_buf, port, s_list, copy)
 308              : scm_lreadparen (tok_buf, port, s_list, copy);
 309     case ')':
 310       scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
 311       goto tryagain;
 312
 313     case '\'':
 314       p = scm_i_quote;
 315       goto recquote;
 316     case '`':
 317       p = scm_i_quasiquote;
 318       goto recquote;
 319     case ',':
 320       c = scm_getc (port);
 321       if ('@' == c)
 322         p = scm_i_uq_splicing;
 323       else
 324         {
 325           scm_ungetc (c, port);
 326           p = scm_i_unquote;
 327         }
 328     recquote:
 329       p = scm_cons2 (p,
 330                      scm_lreadr (tok_buf, port, copy),
 331                      SCM_EOL);
 332       if (SCM_RECORD_POSITIONS_P)
 333         scm_whash_insert (scm_source_whash,
 334                           p,
 335                           scm_make_srcprops (SCM_LINUM (port),
 336                                              SCM_COL (port) - 1,
 337                                              SCM_FILENAME (port),
 338                                              SCM_COPY_SOURCE_P
 339                                              ? (*copy = scm_cons2 (SCM_CAR (p),
 340                                                                    SCM_CAR (SCM_CDR (p)),
 341                                                                    SCM_EOL))
 342                                              : SCM_UNDEFINED,
 343                                              SCM_EOL));
 344       return p;
 345     case '#':
 346       c = scm_getc (port);
 347       switch (c)
 348         {
 349         case '(':
 350           p = scm_lreadparen (tok_buf, port, "vector", copy);
 351           return SCM_NULLP (p) ? scm_nullvect : scm_vector (p);
 352
 353         case 't':
 354         case 'T':
 355           return SCM_BOOL_T;
 356         case 'f':
 357         case 'F':
 358           return SCM_BOOL_F;
 359
 360         case 'b':
 361         case 'B':
 362         case 'o':
 363         case 'O':
 364         case 'd':
 365         case 'D':
 366         case 'x':
 367         case 'X':
 368         case 'i':
 369         case 'I':
 370         case 'e':
 371         case 'E':
 372           scm_ungetc (c, port);
 373           c = '#';
 374           goto num;
 375
 376         case '!':
 377           /* start of a shell script.  Parse as a block comment,
 378              terminated by !#, just like SCSH.  */
 379           skip_scsh_block_comment (port);
 380           /* EOF is not an error here */
 381           c = scm_flush_ws (port, (char *)NULL);
 382           goto tryagain_no_flush_ws;
 383
 384         case '*':
 385           j = scm_read_token (c, tok_buf, port, 0);
 386           p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1));
 387           if (SCM_NFALSEP (p))
 388             return p;
 389           else
 390             goto unkshrp;
 391
 392         case '{':
 393           j = scm_read_token (c, tok_buf, port, 1);
 394           p = scm_intern (SCM_CHARS (*tok_buf), j);
 395           return SCM_CAR (p);
 396
 397         case '\\':
 398           c = scm_getc (port);
 399           j = scm_read_token (c, tok_buf, port, 0);
 400           if (j == 1)
 401             return SCM_MAKICHR (c);
 402           if (c >= '0' && c < '8')
 403             {
 404               p = scm_istr2int (SCM_CHARS (*tok_buf), (long) j, 8);
 405               if (SCM_NFALSEP (p))
 406                 return SCM_MAKICHR (SCM_INUM (p));
 407             }
 408           for (c = 0; c < scm_n_charnames; c++)
 409             if (scm_charnames[c]
 410                 && (scm_casei_streq (scm_charnames[c], SCM_CHARS (*tok_buf))))
 411               return SCM_MAKICHR (scm_charnums[c]);
 412           scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_CHARS (*tok_buf));
 413
 414           /* #:SYMBOL is a syntax for keywords supported in all contexts.  */
 415         case ':':
 416           j = scm_read_token ('-', tok_buf, port, 0);
 417           p = scm_intern (SCM_CHARS (*tok_buf), j);
 418           return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
 419
 420         default:
 421         callshrp:
 422           {
 423             SCM sharp = scm_get_hash_procedure (c);
 424
 425             if (SCM_NIMP (sharp))
 426               {
 427                 int line = SCM_LINUM (port);
 428                 int column = SCM_COL (port) - 2;
 429                 SCM got;
 430
 431                 got = scm_apply (sharp,
 432                                  SCM_MAKICHR (c),
 433                                  scm_acons (port, SCM_EOL, SCM_EOL));
 434                 if (SCM_UNSPECIFIED == got)
 435                   goto unkshrp;
 436                 if (SCM_RECORD_POSITIONS_P)
 437                   return *copy = recsexpr (got, line, column,
 438                                            SCM_FILENAME (port));
 439                 else
 440                   return got;
 441               }
 442           }
 443         unkshrp:
 444           scm_misc_error (s_read, "Unknown # object: %S",
 445                           scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED));
 446         }
 447
 448     case '"':
 449       j = 0;
 450       while ('"' != (c = scm_getc (port)))
 451         {
 452           SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string");
 453
 454           while (j + 2 >= SCM_LENGTH (*tok_buf))
 455             scm_grow_tok_buf (tok_buf);
 456
 457           if (c == '\\')
 458             switch (c = scm_getc (port))
 459               {
 460               case '\n':
 461                 continue;
 462               case '0':
 463                 c = '\0';
 464                 break;
 465               case 'f':
 466                 c = '\f';
 467                 break;
 468               case 'n':
 469                 c = '\n';
 470                 break;
 471               case 'r':
 472                 c = '\r';
 473                 break;
 474               case 't':
 475                 c = '\t';
 476                 break;
 477               case 'a':
 478                 c = '\007';
 479                 break;
 480               case 'v':
 481                 c = '\v';
 482                 break;
 483               }
 484           SCM_CHARS (*tok_buf)[j] = c;
 485           ++j;
 486         }
 487       if (j == 0)
 488         return scm_nullstr;
 489       SCM_CHARS (*tok_buf)[j] = 0;
 490       {
 491         SCM str;
 492         str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0);
 493         return str;
 494       }
 495
 496     case'0':case '1':case '2':case '3':case '4':
 497     case '5':case '6':case '7':case '8':case '9':
 498     case '.':
 499     case '-':
 500     case '+':
 501     num:
 502       j = scm_read_token (c, tok_buf, port, 0);
 503       p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L);
 504       if (SCM_NFALSEP (p))
 505         return p;
 506       if (c == '#')
 507         {
 508           if ((j == 2) && (scm_getc (port) == '('))
 509             {
 510               scm_ungetc ('(', port);
 511               c = SCM_CHARS (*tok_buf)[1];
 512               goto callshrp;
 513             }
 514           scm_wta (SCM_UNDEFINED, "unknown # object", SCM_CHARS (*tok_buf));
 515         }
 516       goto tok;
 517
 518     case ':':
 519       if (SCM_KEYWORD_STYLE == scm_keyword_prefix)
 520         {
 521           j = scm_read_token ('-', tok_buf, port, 0);
 522           p = scm_intern (SCM_CHARS (*tok_buf), j);
 523           return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
 524         }
 525       /* fallthrough */
 526     default:
 527       j = scm_read_token (c, tok_buf, port, 0);
 528       /* fallthrough */
 529
 530     tok:
 531       p = scm_intern (SCM_CHARS (*tok_buf), j);
 532       return SCM_CAR (p);
 533     }
 534 }
 535
 536 #ifdef _UNICOS
 537 _Pragma ("noopt");              /* # pragma _CRI noopt */
 538 #endif
 539
 540 scm_sizet
 541 scm_read_token (ic, tok_buf, port, weird)
 542      int ic;
 543      SCM *tok_buf;
 544      SCM port;
 545      int weird;
 546 {
 547   register scm_sizet j;
 548   register int c;
 549   register char *p;
 550
 551   c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(ic) : ic);
 552   p = SCM_CHARS (*tok_buf);
 553
 554   if (weird)
 555     j = 0;
 556   else
 557     {
 558       j = 0;
 559       while (j + 2 >= SCM_LENGTH (*tok_buf))
 560         p = scm_grow_tok_buf (tok_buf);
 561       p[j] = c;
 562       ++j;
 563     }
 564
 565   while (1)
 566     {
 567       while (j + 2 >= SCM_LENGTH (*tok_buf))
 568         p = scm_grow_tok_buf (tok_buf);
 569       c = scm_getc (port);
 570       switch (c)
 571         {
 572         case '(':
 573         case ')':
 574         case '"':
 575         case ';':
 576         case SCM_WHITE_SPACES:
 577         case SCM_LINE_INCREMENTORS:
 578           if (weird)
 579             goto default_case;
 580
 581           scm_ungetc (c, port);
 582         case EOF:
 583         eof_case:
 584           p[j] = 0;
 585           return j;
 586         case '\\':
 587           if (!weird)
 588             goto default_case;
 589           else
 590             {
 591               c = scm_getc (port);
 592               if (c == EOF)
 593                 goto eof_case;
 594               else
 595                 goto default_case;
 596             }
 597         case '}':
 598           if (!weird)
 599             goto default_case;
 600
 601           c = scm_getc (port);
 602           if (c == '#')
 603             {
 604               p[j] = 0;
 605               return j;
 606             }
 607           else
 608             {
 609               scm_ungetc (c, port);
 610               c = '}';
 611               goto default_case;
 612             }
 613
 614         default:
 615         default_case:
 616           {
 617             c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(c) : c);
 618             p[j] = c;
 619             ++j;
 620           }
 621
 622         }
 623     }
 624 }
 625
 626 #ifdef _UNICOS
 627 _Pragma ("opt");                /* # pragma _CRI opt */
 628 #endif
 629
 630 SCM
 631 scm_lreadparen (tok_buf, port, name, copy)
 632      SCM *tok_buf;
 633      SCM port;
 634      char *name;
 635      SCM *copy;
 636 {
 637   SCM tmp;
 638   SCM tl;
 639   SCM ans;
 640   int c;
 641
 642   c = scm_flush_ws (port, name);
 643   if (')' == c)
 644     return SCM_EOL;
 645   scm_ungetc (c, port);
 646   if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
 647     {
 648       ans = scm_lreadr (tok_buf, port, copy);
 649     closeit:
 650       if (')' != (c = scm_flush_ws (port, name)))
 651         scm_wta (SCM_UNDEFINED, "missing close paren", "");
 652       return ans;
 653     }
 654   ans = tl = scm_cons (tmp, SCM_EOL);
 655   while (')' != (c = scm_flush_ws (port, name)))
 656     {
 657       scm_ungetc (c, port);
 658       if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
 659         {
 660           SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy));
 661           goto closeit;
 662         }
 663       SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
 664       tl = SCM_CDR (tl);
 665     }
 666   return ans;
 667 }
 668
 669
 670 SCM
 671 scm_lreadrecparen (tok_buf, port, name, copy)
 672      SCM *tok_buf;
 673      SCM port;
 674      char *name;
 675      SCM *copy;
 676 {
 677   register int c;
 678   register SCM tmp;
 679   register SCM tl, tl2 = SCM_EOL;
 680   SCM ans, ans2 = SCM_EOL;
 681   /* Need to capture line and column numbers here. */
 682   int line = SCM_LINUM (port);
 683   int column = SCM_COL (port) - 1;
 684
 685   c = scm_flush_ws (port, name);
 686   if (')' == c)
 687     return SCM_EOL;
 688   scm_ungetc (c, port);
 689   if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
 690     {
 691       ans = scm_lreadr (tok_buf, port, copy);
 692       if (')' != (c = scm_flush_ws (port, name)))
 693         scm_wta (SCM_UNDEFINED, "missing close paren", "");
 694       return ans;
 695     }
 696   /* Build the head of the list structure. */
 697   ans = tl = scm_cons (tmp, SCM_EOL);
 698   if (SCM_COPY_SOURCE_P)
 699     ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
 700                            ? *copy
 701                            : tmp,
 702                            SCM_EOL);
 703   while (')' != (c = scm_flush_ws (port, name)))
 704     {
 705       scm_ungetc (c, port);
 706       if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
 707         {
 708           SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy));
 709           if (SCM_COPY_SOURCE_P)
 710             SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
 711                                        ? *copy
 712                                        : tmp,
 713                                        SCM_EOL));
 714           if (')' != (c = scm_flush_ws (port, name)))
 715             scm_wta (SCM_UNDEFINED, "missing close paren", "");
 716           goto exit;
 717         }
 718       tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
 719       if (SCM_COPY_SOURCE_P)
 720         tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
 721                                          ? *copy
 722                                          : tmp,
 723                                          SCM_EOL));
 724     }
 725 exit:
 726   scm_whash_insert (scm_source_whash,
 727                     ans,
 728                     scm_make_srcprops (line,
 729                                        column,
 730                                        SCM_FILENAME (port),
 731                                        SCM_COPY_SOURCE_P
 732                                        ? *copy = ans2
 733                                        : SCM_UNDEFINED,
 734                                        SCM_EOL));
 735   return ans;
 736 }
 737
 738
 739 \f
 740
 741 /* Manipulate the read-hash-procedures alist.  This could be written in
 742    Scheme, but maybe it will also be used by C code during initialisation.  */
 743 SCM_PROC (s_read_hash_extend, "read-hash-extend", 2, 0, 0, scm_read_hash_extend);
 744 SCM
 745 scm_read_hash_extend (chr, proc)
 746      SCM chr;
 747      SCM proc;
 748 {
 749   SCM this;
 750   SCM prev;
 751
 752   SCM_ASSERT (SCM_ICHRP(chr), chr, SCM_ARG1, s_read_hash_extend);
 753   SCM_ASSERT (SCM_FALSEP (proc) || SCM_NIMP(proc), proc, SCM_ARG2,
 754               s_read_hash_extend);
 755
 756   /* Check if chr is already in the alist.  */
 757   this = *scm_read_hash_procedures;
 758   prev = SCM_BOOL_F;
 759   while (1)
 760     {
 761       if (SCM_NULLP (this))
 762         {
 763           /* not found, so add it to the beginning.  */
 764           if (SCM_NFALSEP (proc))
 765             {
 766               *scm_read_hash_procedures =
 767                 scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
 768             }
 769           break;
 770         }
 771       if (chr == SCM_CAAR (this))
 772         {
 773           /* already in the alist.  */
 774           if (SCM_FALSEP (proc))
 775             {
 776               /* remove it.  */
 777               if (prev == SCM_BOOL_F)
 778                 {
 779                   *scm_read_hash_procedures =
 780                     SCM_CDR (*scm_read_hash_procedures);
 781                 }
 782               else
 783                 scm_set_cdr_x (prev, SCM_CDR (this));
 784             }
 785           else
 786             {
 787               /* replace it.  */
 788               scm_set_cdr_x (SCM_CAR (this), proc);
 789             }
 790           break;
 791         }
 792       prev = this;
 793       this = SCM_CDR (this);
 794     }
 795
 796   return SCM_UNSPECIFIED;
 797 }
 798
 799 /* Recover the read-hash procedure corresponding to char c.  */
 800 static SCM
 801 scm_get_hash_procedure (c)
 802      int c;
 803 {
 804   SCM rest = *scm_read_hash_procedures;
 805
 806   while (1)
 807     {
 808       if (SCM_NULLP (rest))
 809         return SCM_BOOL_F;
 810
 811       if (SCM_ICHR (SCM_CAAR (rest)) == c)
 812         return SCM_CDAR (rest);
 813
 814       rest = SCM_CDR (rest);
 815     }
 816 }
 817
 818 void
 819 scm_init_read ()
 820 {
 821   scm_read_hash_procedures =
 822     SCM_CDRLOC (scm_sysintern ("read-hash-procedures", SCM_EOL));
 823
 824   scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
 825 #include "read.x"
 826 }