1 /* Copyright (C) 1995,1996 Free Software Foundation, Inc.
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)
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.
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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
50 #include "mbstrings.h"
61 #define default_case_i 0
65 scm_option scm_read_opts
[] = {
66 { SCM_OPTION_BOOLEAN
, "copy", 0,
67 "Copy source code expressions." },
68 { SCM_OPTION_BOOLEAN
, "positions", 0,
69 "Record positions of source code expressions." }
72 SCM_PROC (s_read_options
, "read-options-interface", 0, 1, 0, scm_read_options
);
75 scm_read_options (setting
)
78 SCM ans
= scm_options (setting
,
82 if (SCM_COPY_SOURCE_P
)
83 SCM_RECORD_POSITIONS_P
= 1;
87 SCM_PROC (s_read
, "read", 0, 3, 0, scm_read
);
90 scm_read (port
, case_insensitive_p
, sharp
)
92 SCM case_insensitive_p
;
99 if (SCM_UNBNDP (port
))
102 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
107 case_i
= (SCM_UNBNDP (case_insensitive_p
)
109 : (case_insensitive_p
== SCM_BOOL_F
));
111 if (SCM_UNBNDP (sharp
))
114 c
= scm_flush_ws (port
, (char *) NULL
);
117 scm_gen_ungetc (c
, port
);
119 tok_buf
= scm_makstr (30L, 0);
120 return scm_lreadr (&tok_buf
, port
, case_i
, sharp
, ©
);
126 scm_grow_tok_buf (tok_buf
)
129 scm_vector_set_length_x (*tok_buf
, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf
)));
130 return SCM_CHARS (*tok_buf
);
136 scm_flush_ws (port
, eoferr
)
142 switch (c
= scm_gen_getc (port
))
147 scm_wta (SCM_UNDEFINED
, "end of file in ", eoferr
);
151 switch (c
= scm_gen_getc (port
))
157 case SCM_LINE_INCREMENTORS
:
161 case SCM_LINE_INCREMENTORS
:
162 case SCM_SINGLE_SPACES
:
173 scm_casei_streq (s1
, s2
)
178 if (scm_downcase((int)*s1
) != scm_downcase((int)*s2
))
185 return !(*s1
|| *s2
);
189 /* recsexpr is used when recording expressions
190 * constructed by read:sharp.
193 static SCM recsexpr
SCM_P ((SCM obj
, int line
, int column
, SCM filename
));
196 recsexpr (obj
, line
, column
, filename
)
202 if (SCM_IMP (obj
) || SCM_NCONSP(obj
))
206 /* If this sexpr is visible in the read:sharp source, we want to
207 keep that information, so only record non-constant cons cells
208 which haven't previously been read by the reader. */
209 if (SCM_FALSEP (scm_whash_lookup (scm_source_whash
, obj
)))
211 if (SCM_COPY_SOURCE_P
)
213 copy
= scm_cons (recsexpr (SCM_CAR (obj
), line
, column
, filename
),
215 while (SCM_NIMP (tmp
= SCM_CDR (tmp
)) && SCM_CONSP (tmp
))
217 SCM_SETCDR (copy
, scm_cons (recsexpr (SCM_CAR (tmp
),
222 copy
= SCM_CDR (copy
);
224 SCM_SETCDR (copy
, tmp
);
228 recsexpr (SCM_CAR (obj
), line
, column
, filename
);
229 while (SCM_NIMP (tmp
= SCM_CDR (tmp
)) && SCM_CONSP (tmp
))
230 recsexpr (SCM_CAR (tmp
), line
, column
, filename
);
231 copy
= SCM_UNDEFINED
;
233 scm_whash_insert (scm_source_whash
,
235 scm_make_srcprops (line
,
246 /* Consume an SCSH-style block comment. Assume that we've already
247 read the initial `#!', and eat characters until the matching `!#'. */
250 skip_scsh_block_comment (port
)
257 int c
= scm_gen_getc (port
);
260 scm_wta (SCM_UNDEFINED
,
261 "unterminated `#! ... !#' comment", "read");
262 else if (c
== '#' && last_c
== '!')
270 static char s_list
[]="list";
273 scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
)
285 c
= scm_flush_ws (port
, s_read
);
292 return SCM_RECORD_POSITIONS_P
293 ? scm_lreadrecparen (tok_buf
, port
, s_list
, case_i
, sharp
, copy
)
294 : scm_lreadparen (tok_buf
, port
, s_list
, case_i
, sharp
, copy
);
296 scm_wta (SCM_UNDEFINED
, "unexpected \")\"", "read");
303 p
= scm_i_quasiquote
;
306 c
= scm_gen_getc (port
);
308 p
= scm_i_uq_splicing
;
311 scm_gen_ungetc (c
, port
);
316 scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
),
318 if (SCM_RECORD_POSITIONS_P
)
319 scm_whash_insert (scm_source_whash
,
321 scm_make_srcprops (SCM_LINUM (port
),
325 ? (*copy
= scm_cons2 (SCM_CAR (p
),
326 SCM_CAR (SCM_CDR (p
)),
332 c
= scm_gen_getc (port
);
336 p
= scm_lreadparen (tok_buf
, port
, "vector", case_i
, sharp
, copy
);
337 return SCM_NULLP (p
) ? scm_nullvect
: scm_vector (p
);
358 scm_gen_ungetc (c
, port
);
363 /* start of a shell script. Parse as a block comment,
364 terminated by !#, just like SCSH. */
365 skip_scsh_block_comment (port
);
369 j
= scm_read_token (c
, tok_buf
, port
, case_i
, 0);
370 p
= scm_istr2bve (SCM_CHARS (*tok_buf
) + 1, (long) (j
- 1));
377 j
= scm_read_token (c
, tok_buf
, port
, case_i
, 1);
378 p
= scm_intern (SCM_CHARS (*tok_buf
), j
);
379 if (SCM_PORT_REPRESENTATION (port
) != scm_regular_port
)
380 scm_set_symbol_multi_byte_x (SCM_CAR (p
), SCM_BOOL_T
);
384 c
= scm_gen_getc (port
);
385 j
= scm_read_token (c
, tok_buf
, port
, case_i
, 0);
387 return SCM_MAKICHR (c
);
388 if (c
>= '0' && c
< '8')
390 p
= scm_istr2int (SCM_CHARS (*tok_buf
), (long) j
, 8);
392 return SCM_MAKICHR (SCM_INUM (p
));
394 for (c
= 0; c
< scm_n_charnames
; c
++)
396 && (scm_casei_streq (scm_charnames
[c
], SCM_CHARS (*tok_buf
))))
397 return SCM_MAKICHR (scm_charnums
[c
]);
398 scm_wta (SCM_UNDEFINED
, "unknown # object: #\\", SCM_CHARS (*tok_buf
));
403 if (SCM_NIMP (sharp
))
405 int line
= SCM_LINUM (port
);
406 int column
= SCM_COL (port
) - 2;
408 got
= scm_apply (sharp
,
410 scm_acons (port
, SCM_EOL
, SCM_EOL
));
411 if (SCM_UNSPECIFIED
== got
)
413 if (SCM_RECORD_POSITIONS_P
)
414 return *copy
= recsexpr (got
, line
, column
,
415 SCM_FILENAME (port
));
419 unkshrp
:scm_wta ((SCM
) SCM_MAKICHR (c
), "unknown # object", "");
424 while ('"' != (c
= scm_gen_getc (port
)))
426 SCM_ASSERT (EOF
!= c
, SCM_UNDEFINED
, "end of file in ", "string");
428 while (j
+ sizeof(xwchar_t
) + XMB_CUR_MAX
>= SCM_LENGTH (*tok_buf
))
429 scm_grow_tok_buf (tok_buf
);
432 switch (c
= scm_gen_getc (port
))
458 if (SCM_PORT_REPRESENTATION(port
) == scm_regular_port
)
460 SCM_CHARS (*tok_buf
)[j
] = c
;
466 len
= xwctomb (SCM_CHARS (*tok_buf
) + j
, c
);
469 SCM_ASSERT (len
> 0, SCM_MAKINUM (c
), "bogus char", "read");
475 SCM_CHARS (*tok_buf
)[j
] = 0;
478 str
= scm_makfromstr (SCM_CHARS (*tok_buf
), j
, 0);
479 if (SCM_PORT_REPRESENTATION(port
) != scm_regular_port
)
481 SCM_SETLENGTH (str
, SCM_LENGTH (str
), scm_tc7_mb_string
);
486 case'0':case '1':case '2':case '3':case '4':
487 case '5':case '6':case '7':case '8':case '9':
492 j
= scm_read_token (c
, tok_buf
, port
, case_i
, 0);
493 p
= scm_istring2number (SCM_CHARS (*tok_buf
), (long) j
, 10L);
498 if ((j
== 2) && (scm_gen_getc (port
) == '('))
500 scm_gen_ungetc ('(', port
);
501 c
= SCM_CHARS (*tok_buf
)[1];
504 scm_wta (SCM_UNDEFINED
, "unknown # object", SCM_CHARS (*tok_buf
));
509 j
= scm_read_token ('-', tok_buf
, port
, case_i
, 0);
510 p
= scm_intern (SCM_CHARS (*tok_buf
), j
);
511 if (SCM_PORT_REPRESENTATION (port
) != scm_regular_port
)
512 scm_set_symbol_multi_byte_x (SCM_CAR (p
), SCM_BOOL_T
);
513 return scm_make_keyword_from_dash_symbol (SCM_CAR (p
));
516 j
= scm_read_token (c
, tok_buf
, port
, case_i
, 0);
520 p
= scm_intern (SCM_CHARS (*tok_buf
), j
);
521 if (SCM_PORT_REPRESENTATION (port
) != scm_regular_port
)
522 scm_set_symbol_multi_byte_x (SCM_CAR (p
), SCM_BOOL_T
);
528 _Pragma ("noopt"); /* # pragma _CRI noopt */
532 scm_read_token (ic
, tok_buf
, port
, case_i
, weird
)
539 register scm_sizet j
;
544 p
= SCM_CHARS (*tok_buf
);
551 while (j
+ sizeof(xwchar_t
) + XMB_CUR_MAX
>= SCM_LENGTH (*tok_buf
))
552 p
= scm_grow_tok_buf (tok_buf
);
553 if (SCM_PORT_REPRESENTATION(port
) == scm_regular_port
)
561 len
= xwctomb (p
+ j
, c
);
564 SCM_ASSERT (len
> 0, SCM_MAKINUM (c
), "bogus char", "read");
571 while (j
+ sizeof(xwchar_t
) + XMB_CUR_MAX
>= SCM_LENGTH (*tok_buf
))
572 p
= scm_grow_tok_buf (tok_buf
);
573 c
= scm_gen_getc (port
);
580 case SCM_WHITE_SPACES
:
581 case SCM_LINE_INCREMENTORS
:
585 scm_gen_ungetc (c
, port
);
595 c
= scm_gen_getc (port
);
605 c
= scm_gen_getc (port
);
613 scm_gen_ungetc (c
, port
);
621 c
= (case_i
? scm_downcase(c
) : c
);
622 if (SCM_PORT_REPRESENTATION(port
) == scm_regular_port
)
630 len
= xwctomb (p
+ j
, c
);
633 SCM_ASSERT (len
> 0, SCM_MAKINUM (c
), "bogus char", "read");
643 _Pragma ("opt"); /* # pragma _CRI opt */
647 scm_lreadparen (tok_buf
, port
, name
, case_i
, sharp
, copy
)
660 c
= scm_flush_ws (port
, name
);
663 scm_gen_ungetc (c
, port
);
664 if (scm_i_dot
== (tmp
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
)))
666 ans
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
);
668 if (')' != (c
= scm_flush_ws (port
, name
)))
669 scm_wta (SCM_UNDEFINED
, "missing close paren", "");
672 ans
= tl
= scm_cons (tmp
, SCM_EOL
);
673 while (')' != (c
= scm_flush_ws (port
, name
)))
675 scm_gen_ungetc (c
, port
);
676 if (scm_i_dot
== (tmp
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
)))
678 SCM_SETCDR (tl
, scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
));
681 SCM_SETCDR (tl
, scm_cons (tmp
, SCM_EOL
));
689 scm_lreadrecparen (tok_buf
, port
, name
, case_i
, sharp
, copy
)
699 register SCM tl
, tl2
;
701 /* Need to capture line and column numbers here. */
702 int line
= SCM_LINUM (port
);
703 int column
= SCM_COL (port
) - 1;
705 c
= scm_flush_ws (port
, name
);
708 scm_gen_ungetc (c
, port
);
709 if (scm_i_dot
== (tmp
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
)))
711 ans
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
);
712 if (')' != (c
= scm_flush_ws (port
, name
)))
713 scm_wta (SCM_UNDEFINED
, "missing close paren", "");
716 /* Build the head of the list structure. */
717 ans
= tl
= scm_cons (tmp
, SCM_EOL
);
718 if (SCM_COPY_SOURCE_P
)
719 ans2
= tl2
= scm_cons (SCM_NIMP (tmp
) && SCM_CONSP (tmp
)
723 while (')' != (c
= scm_flush_ws (port
, name
)))
725 scm_gen_ungetc (c
, port
);
726 if (scm_i_dot
== (tmp
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
)))
728 SCM_SETCDR (tl
, tmp
= scm_lreadr (tok_buf
, port
, case_i
, sharp
, copy
));
729 if (SCM_COPY_SOURCE_P
)
730 SCM_SETCDR (tl2
, scm_cons (SCM_NIMP (tmp
) && SCM_CONSP (tmp
)
734 if (')' != (c
= scm_flush_ws (port
, name
)))
735 scm_wta (SCM_UNDEFINED
, "missing close paren", "");
738 tl
= SCM_SETCDR (tl
, scm_cons (tmp
, SCM_EOL
));
739 if (SCM_COPY_SOURCE_P
)
740 tl2
= SCM_SETCDR (tl2
, scm_cons (SCM_NIMP (tmp
) && SCM_CONSP (tmp
)
746 scm_whash_insert (scm_source_whash
,
748 scm_make_srcprops (line
,
766 scm_init_opts (scm_read_options
, scm_read_opts
, SCM_N_READ_OPTIONS
);