← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/read.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

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