X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/82892beda5c053715bc3ec7063af4a129f52c5f9..0d48aca5273f0a8454db374c1deb4c5084cf778a:/libguile/read.c diff --git a/libguile/read.c b/libguile/read.c index c5eac9edf..6046023a8 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -38,112 +38,168 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + + -#include "extchrs.h" #include -#include "_scm.h" -#include "chars.h" -#include "genio.h" -#include "eval.h" -#include "unif.h" -#include "mbstrings.h" -#include "kw.h" -#include "alist.h" -#include "srcprop.h" -#include "hashtab.h" -#include "hash.h" - -#include "read.h" +#include "libguile/_scm.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/unif.h" +#include "libguile/keywords.h" +#include "libguile/alist.h" +#include "libguile/srcprop.h" +#include "libguile/hashtab.h" +#include "libguile/hash.h" +#include "libguile/ports.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/strports.h" +#include "libguile/vectors.h" +#include "libguile/validate.h" + +#include "libguile/read.h" SCM_SYMBOL (scm_keyword_prefix, "prefix"); -scm_option scm_read_opts[] = { +scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "copy", 0, "Copy source code expressions." }, { SCM_OPTION_BOOLEAN, "positions", 0, "Record positions of source code expressions." }, { SCM_OPTION_BOOLEAN, "case-insensitive", 0, "Convert symbols to lower case."}, - { SCM_OPTION_SCM, "keywords", SCM_BOOL_F, - "Style of keyword recognition: #f or 'prefix"} + { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F), + "Style of keyword recognition: #f or 'prefix."} }; -SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options); +/* + Give meaningful error messages for errors + + We use the format + + FILE:LINE:COL: MESSAGE + This happened in .... + + This is not standard GNU format, but the test-suite likes the real + message to be in front. -SCM -scm_read_options (setting) - SCM setting; + */ + + +static void +scm_input_error(char const * function, + SCM port, const char * message, SCM arg) +{ + char *fn = SCM_STRINGP (SCM_FILENAME(port)) + ? SCM_STRING_CHARS(SCM_FILENAME(port)) + : "#"; + + SCM string_port = scm_open_output_string (); + SCM string = SCM_EOL; + scm_simple_format (string_port, + scm_makfrom0str ("~A:~S:~S: ~A"), + scm_list_4 (scm_makfrom0str (fn), + scm_int2num (SCM_LINUM (port) + 1), + scm_int2num (SCM_COL (port) + 1), + scm_makfrom0str (message))); + + + string = scm_get_output_string (string_port); + scm_close_output_port (string_port); + scm_error_scm (scm_str2symbol ("read-error"), + scm_makfrom0str (function), + string, + SCM_EOL, + SCM_BOOL_F); +} + + +SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, + (SCM setting), + "Option interface for the read options. Instead of using\n" + "this procedure directly, use the procedures @code{read-enable},\n" + "@code{read-disable}, @code{read-set!} and @code{read-options}.") +#define FUNC_NAME s_scm_read_options { SCM ans = scm_options (setting, scm_read_opts, SCM_N_READ_OPTIONS, - s_read_options); + FUNC_NAME); if (SCM_COPY_SOURCE_P) SCM_RECORD_POSITIONS_P = 1; return ans; } +#undef FUNC_NAME /* An association list mapping extra hash characters to procedures. */ static SCM *scm_read_hash_procedures; -SCM_PROC (s_read, "read", 0, 1, 0, scm_read); - -SCM -scm_read (port) - SCM port; +SCM_DEFINE (scm_read, "read", 0, 1, 0, + (SCM port), + "Read an s-expression from the input port @var{port}, or from\n" + "the current input port if @var{port} is not specified.\n" + "Any whitespace before the next token is discarded.") +#define FUNC_NAME s_scm_read { int c; SCM tok_buf, copy; if (SCM_UNBNDP (port)) port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, - SCM_ARG1, - s_read); + SCM_VALIDATE_OPINPORT (1, port); c = scm_flush_ws (port, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; - scm_gen_ungetc (c, port); + scm_ungetc (c, port); - tok_buf = scm_makstr (30L, 0); + tok_buf = scm_allocate_string (30); return scm_lreadr (&tok_buf, port, ©); } +#undef FUNC_NAME char * -scm_grow_tok_buf (tok_buf) - SCM * tok_buf; +scm_grow_tok_buf (SCM *tok_buf) { - scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf))); - return SCM_CHARS (*tok_buf); + size_t oldlen = SCM_STRING_LENGTH (*tok_buf); + SCM newstr = scm_allocate_string (2 * oldlen); + size_t i; + + for (i = 0; i != oldlen; ++i) + SCM_STRING_CHARS (newstr) [i] = SCM_STRING_CHARS (*tok_buf) [i]; + + *tok_buf = newstr; + return SCM_STRING_CHARS (newstr); } int -scm_flush_ws (port, eoferr) - SCM port; - char *eoferr; +scm_flush_ws (SCM port, const char *eoferr) { register int c; while (1) - switch (c = scm_gen_getc (port)) + switch (c = scm_getc (port)) { case EOF: goteof: if (eoferr) - scm_wta (SCM_UNDEFINED, "end of file in ", eoferr); + { + scm_input_error (eoferr, + port, + "end of file", + SCM_EOL); + } return c; case ';': lp: - switch (c = scm_gen_getc (port)) + switch (c = scm_getc (port)) { case EOF: goto goteof; @@ -165,9 +221,7 @@ scm_flush_ws (port, eoferr) int -scm_casei_streq (s1, s2) - char * s1; - char * s2; +scm_casei_streq (char *s1, char *s2) { while (*s1 && *s2) if (scm_downcase((int)*s1) != scm_downcase((int)*s2)) @@ -184,19 +238,15 @@ scm_casei_streq (s1, s2) /* recsexpr is used when recording expressions * constructed by read:sharp. */ - -static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename)); - +#ifndef DEBUG_EXTENSIONS +#define recsexpr(obj, line, column, filename) (obj) +#else static SCM -recsexpr (obj, line, column, filename) - SCM obj; - int line; - int column; - SCM filename; +recsexpr (SCM obj, long line, int column, SCM filename) { - if (SCM_IMP (obj) || SCM_NCONSP(obj)) + if (!SCM_CONSP(obj)) { return obj; - { + } else { SCM tmp = obj, copy; /* If this sexpr is visible in the read:sharp source, we want to keep that information, so only record non-constant cons cells @@ -207,7 +257,7 @@ recsexpr (obj, line, column, filename) { copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename), SCM_UNDEFINED); - while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) + while ((tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) { SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp), line, @@ -221,7 +271,7 @@ recsexpr (obj, line, column, filename) else { recsexpr (SCM_CAR (obj), line, column, filename); - while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) + while ((tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) recsexpr (SCM_CAR (tmp), line, column, filename); copy = SCM_UNDEFINED; } @@ -236,15 +286,15 @@ recsexpr (obj, line, column, filename) return obj; } } - +#endif /* Consume an SCSH-style block comment. Assume that we've already read the initial `#!', and eat characters until we get a newline/exclamation-point/sharp-sign/newline sequence. */ static void -skip_scsh_block_comment (port) - SCM port; +skip_scsh_block_comment (SCM port) +#define FUNC_NAME "skip_scsh_block_comment" { /* Is this portable? Dear God, spare me from the non-eight-bit characters. But is it tasteful? */ @@ -252,11 +302,10 @@ skip_scsh_block_comment (port) for (;;) { - int c = scm_gen_getc (port); + int c = scm_getc (port); if (c == EOF) - scm_wta (SCM_UNDEFINED, - "unterminated `#! ... !#' comment", "read"); + SCM_MISC_ERROR ("unterminated `#! ... !#' comment", SCM_EOL); history = ((history << 8) | (c & 0xff)) & 0xffffffff; /* Were the last four characters read "\n!#\n"? */ @@ -264,25 +313,24 @@ skip_scsh_block_comment (port) return; } } +#undef FUNC_NAME -static SCM -scm_get_hash_procedure SCM_P ((int c)); + +static SCM scm_get_hash_procedure(int c); static char s_list[]="list"; SCM -scm_lreadr (tok_buf, port, copy) - SCM *tok_buf; - SCM port; - SCM *copy; +scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) +#define FUNC_NAME "scm_lreadr" { int c; - scm_sizet j; + size_t j; SCM p; -tryagain: - c = scm_flush_ws (port, s_read); -tryagain_no_flush_ws: + tryagain: + c = scm_flush_ws (port, s_scm_read); + tryagain_no_flush_ws: switch (c) { case EOF: @@ -290,26 +338,26 @@ tryagain_no_flush_ws: case '(': return SCM_RECORD_POSITIONS_P - ? scm_lreadrecparen (tok_buf, port, s_list, copy) - : scm_lreadparen (tok_buf, port, s_list, copy); + ? scm_lreadrecparen (tok_buf, port, s_list, copy) + : scm_lreadparen (tok_buf, port, s_list, copy); case ')': - scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); + scm_input_error (FUNC_NAME, port,"unexpected \")\"", SCM_EOL); goto tryagain; case '\'': - p = scm_i_quote; + p = scm_sym_quote; goto recquote; case '`': - p = scm_i_quasiquote; + p = scm_sym_quasiquote; goto recquote; case ',': - c = scm_gen_getc (port); + c = scm_getc (port); if ('@' == c) - p = scm_i_uq_splicing; + p = scm_sym_uq_splicing; else { - scm_gen_ungetc (c, port); - p = scm_i_unquote; + scm_ungetc (c, port); + p = scm_sym_unquote; } recquote: p = scm_cons2 (p, @@ -329,7 +377,29 @@ tryagain_no_flush_ws: SCM_EOL)); return p; case '#': - c = scm_gen_getc (port); + c = scm_getc (port); + + { + /* Check for user-defined hash procedure first, to allow + overriding of builtin hash read syntaxes. */ + SCM sharp = scm_get_hash_procedure (c); + if (!SCM_FALSEP (sharp)) + { + int line = SCM_LINUM (port); + int column = SCM_COL (port) - 2; + SCM got; + + got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); + if (SCM_EQ_P (got, SCM_UNSPECIFIED)) + goto handle_sharp; + if (SCM_RECORD_POSITIONS_P) + return *copy = recsexpr (got, line, column, + SCM_FILENAME (port)); + else + return got; + } + } + handle_sharp: switch (c) { case '(': @@ -355,7 +425,7 @@ tryagain_no_flush_ws: case 'I': case 'e': case 'E': - scm_gen_ungetc (c, port); + scm_ungetc (c, port); c = '#'; goto num; @@ -367,54 +437,61 @@ tryagain_no_flush_ws: c = scm_flush_ws (port, (char *)NULL); goto tryagain_no_flush_ws; +#ifdef HAVE_ARRAYS case '*': j = scm_read_token (c, tok_buf, port, 0); - p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1)); - if (SCM_NFALSEP (p)) + p = scm_istr2bve (SCM_STRING_CHARS (*tok_buf) + 1, (long) (j - 1)); + if (!SCM_FALSEP (p)) return p; else goto unkshrp; +#endif case '{': j = scm_read_token (c, tok_buf, port, 1); - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return SCM_CAR (p); + return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); case '\\': - c = scm_gen_getc (port); + c = scm_getc (port); j = scm_read_token (c, tok_buf, port, 0); if (j == 1) - return SCM_MAKICHR (c); + return SCM_MAKE_CHAR (c); if (c >= '0' && c < '8') { - p = scm_istr2int (SCM_CHARS (*tok_buf), (long) j, 8); - if (SCM_NFALSEP (p)) - return SCM_MAKICHR (SCM_INUM (p)); + /* Dirk:FIXME:: This type of character syntax is not R5RS + * compliant. Further, it should be verified that the constant + * does only consist of octal digits. Finally, it should be + * checked whether the resulting fixnum is in the range of + * characters. */ + p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 8); + if (SCM_INUMP (p)) + return SCM_MAKE_CHAR (SCM_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) if (scm_charnames[c] - && (scm_casei_streq (scm_charnames[c], SCM_CHARS (*tok_buf)))) - return SCM_MAKICHR (scm_charnums[c]); - scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_CHARS (*tok_buf)); + && (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf)))) + return SCM_MAKE_CHAR (scm_charnums[c]); + scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); + /* #:SYMBOL is a syntax for keywords supported in all contexts. */ + case ':': + j = scm_read_token ('-', tok_buf, port, 0); + p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_make_keyword_from_dash_symbol (p); default: callshrp: { SCM sharp = scm_get_hash_procedure (c); - if (SCM_NIMP (sharp)) + if (!SCM_FALSEP (sharp)) { int line = SCM_LINUM (port); int column = SCM_COL (port) - 2; SCM got; - got = scm_apply (sharp, - SCM_MAKICHR (c), - scm_acons (port, SCM_EOL, SCM_EOL)); - if (SCM_UNSPECIFIED == got) + got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); + if (SCM_EQ_P (got, SCM_UNSPECIFIED)) goto unkshrp; if (SCM_RECORD_POSITIONS_P) return *copy = recsexpr (got, line, column, @@ -424,21 +501,22 @@ tryagain_no_flush_ws: } } unkshrp: - scm_misc_error (s_read, "Unknown # object: %S", - scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED)); + scm_input_error (FUNC_NAME, port, "Unknown # object: ~S", + scm_list_1 (SCM_MAKE_CHAR (c))); } case '"': j = 0; - while ('"' != (c = scm_gen_getc (port))) + while ('"' != (c = scm_getc (port))) { - SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string"); + if (c == EOF) + scm_input_error (FUNC_NAME, port, "end of file in string constant", SCM_EOL); - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) + while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) scm_grow_tok_buf (tok_buf); if (c == '\\') - switch (c = scm_gen_getc (port)) + switch (c = scm_getc (port)) { case '\n': continue; @@ -464,64 +542,46 @@ tryagain_no_flush_ws: c = '\v'; break; } - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - SCM_CHARS (*tok_buf)[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (SCM_CHARS (*tok_buf) + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } + SCM_STRING_CHARS (*tok_buf)[j] = c; + ++j; } if (j == 0) return scm_nullstr; - SCM_CHARS (*tok_buf)[j] = 0; - { - SCM str; - str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0); - if (SCM_PORT_REPRESENTATION(port) != scm_regular_port) - { - SCM_SETLENGTH (str, SCM_LENGTH (str), scm_tc7_mb_string); - } - return str; - } + SCM_STRING_CHARS (*tok_buf)[j] = 0; + return scm_mem2string (SCM_STRING_CHARS (*tok_buf), j); - case'0':case '1':case '2':case '3':case '4': - case '5':case '6':case '7':case '8':case '9': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '.': case '-': case '+': num: j = scm_read_token (c, tok_buf, port, 0); - p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L); - if (SCM_NFALSEP (p)) + if (j == 1 && (c == '+' || c == '-')) + /* Shortcut: Detected symbol '+ or '- */ + goto tok; + + p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 10); + if (!SCM_FALSEP (p)) return p; if (c == '#') { - if ((j == 2) && (scm_gen_getc (port) == '(')) + if ((j == 2) && (scm_getc (port) == '(')) { - scm_gen_ungetc ('(', port); - c = SCM_CHARS (*tok_buf)[1]; + scm_ungetc ('(', port); + c = SCM_STRING_CHARS (*tok_buf)[1]; goto callshrp; } - scm_wta (SCM_UNDEFINED, "unknown # object", SCM_CHARS (*tok_buf)); + scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); } goto tok; case ':': - if (SCM_KEYWORD_STYLE == scm_keyword_prefix) + if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); + p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_make_keyword_from_dash_symbol (p); } /* fallthrough */ default: @@ -529,59 +589,42 @@ tryagain_no_flush_ws: /* fallthrough */ tok: - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return SCM_CAR (p); + return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); } } +#undef FUNC_NAME + #ifdef _UNICOS _Pragma ("noopt"); /* # pragma _CRI noopt */ #endif -scm_sizet -scm_read_token (ic, tok_buf, port, weird) - int ic; - SCM *tok_buf; - SCM port; - int weird; +size_t +scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) { - register scm_sizet j; + register size_t j; register int c; register char *p; c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(ic) : ic); - p = SCM_CHARS (*tok_buf); + p = SCM_STRING_CHARS (*tok_buf); if (weird) j = 0; else { j = 0; - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) + while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) p = scm_grow_tok_buf (tok_buf); - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - p[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (p + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } + p[j] = c; + ++j; } while (1) { - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) + while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) p = scm_grow_tok_buf (tok_buf); - c = scm_gen_getc (port); + c = scm_getc (port); switch (c) { case '(': @@ -593,7 +636,7 @@ scm_read_token (ic, tok_buf, port, weird) if (weird) goto default_case; - scm_gen_ungetc (c, port); + scm_ungetc (c, port); case EOF: eof_case: p[j] = 0; @@ -603,7 +646,7 @@ scm_read_token (ic, tok_buf, port, weird) goto default_case; else { - c = scm_gen_getc (port); + c = scm_getc (port); if (c == EOF) goto eof_case; else @@ -613,7 +656,7 @@ scm_read_token (ic, tok_buf, port, weird) if (!weird) goto default_case; - c = scm_gen_getc (port); + c = scm_getc (port); if (c == '#') { p[j] = 0; @@ -621,7 +664,7 @@ scm_read_token (ic, tok_buf, port, weird) } else { - scm_gen_ungetc (c, port); + scm_ungetc (c, port); c = '}'; goto default_case; } @@ -630,20 +673,8 @@ scm_read_token (ic, tok_buf, port, weird) default_case: { c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(c) : c); - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - p[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (p + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } + p[j] = c; + ++j; } } @@ -655,11 +686,8 @@ _Pragma ("opt"); /* # pragma _CRI opt */ #endif SCM -scm_lreadparen (tok_buf, port, name, copy) - SCM *tok_buf; - SCM port; - char *name; - SCM *copy; +scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) +#define FUNC_NAME "scm_lreadparen" { SCM tmp; SCM tl; @@ -669,20 +697,20 @@ scm_lreadparen (tok_buf, port, name, copy) c = scm_flush_ws (port, name); if (')' == c) return SCM_EOL; - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) + scm_ungetc (c, port); + if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { ans = scm_lreadr (tok_buf, port, copy); closeit: if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + scm_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); return ans; } ans = tl = scm_cons (tmp, SCM_EOL); while (')' != (c = scm_flush_ws (port, name))) { - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) + scm_ungetc (c, port); + if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy)); goto closeit; @@ -692,14 +720,12 @@ scm_lreadparen (tok_buf, port, name, copy) } return ans; } +#undef FUNC_NAME SCM -scm_lreadrecparen (tok_buf, port, name, copy) - SCM *tok_buf; - SCM port; - char *name; - SCM *copy; +scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) +#define FUNC_NAME "scm_lreadrecparen" { register int c; register SCM tmp; @@ -712,42 +738,49 @@ scm_lreadrecparen (tok_buf, port, name, copy) c = scm_flush_ws (port, name); if (')' == c) return SCM_EOL; - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) + scm_ungetc (c, port); + if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { ans = scm_lreadr (tok_buf, port, copy); if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + scm_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); return ans; } /* Build the head of the list structure. */ ans = tl = scm_cons (tmp, SCM_EOL); if (SCM_COPY_SOURCE_P) - ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) + ans2 = tl2 = scm_cons (SCM_CONSP (tmp) ? *copy : tmp, SCM_EOL); while (')' != (c = scm_flush_ws (port, name))) { - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) + SCM new_tail; + + scm_ungetc (c, port); + if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy)); if (SCM_COPY_SOURCE_P) - SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) + SCM_SETCDR (tl2, scm_cons (SCM_CONSP (tmp) ? *copy : tmp, SCM_EOL)); if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + scm_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); goto exit; } - tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); + + new_tail = scm_cons (tmp, SCM_EOL); + SCM_SETCDR (tl, new_tail); + tl = new_tail; + if (SCM_COPY_SOURCE_P) - tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL)); + { + SCM new_tail2 = scm_cons (SCM_CONSP (tmp) ? *copy : tmp, SCM_EOL); + SCM_SETCDR (tl2, new_tail2); + tl2 = new_tail2; + } } exit: scm_whash_insert (scm_source_whash, @@ -761,24 +794,29 @@ exit: SCM_EOL)); return ans; } +#undef FUNC_NAME /* Manipulate the read-hash-procedures alist. This could be written in Scheme, but maybe it will also be used by C code during initialisation. */ -SCM_PROC (s_read_hash_extend, "read-hash-extend", 2, 0, 0, scm_read_hash_extend); -SCM -scm_read_hash_extend (chr, proc) - SCM chr; - SCM proc; +SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, + (SCM chr, SCM proc), + "Install the procedure @var{proc} for reading expressions\n" + "starting with the character sequence @code{#} and @var{chr}.\n" + "@var{proc} will be called with two arguments: the character\n" + "@var{chr} and the port to read further data from. The object\n" + "returned will be the return value of @code{read}.") +#define FUNC_NAME s_scm_read_hash_extend { SCM this; SCM prev; - SCM_ASSERT (SCM_ICHRP(chr), chr, SCM_ARG1, s_read_hash_extend); - SCM_ASSERT (SCM_FALSEP (proc) || SCM_NIMP(proc), proc, SCM_ARG2, - s_read_hash_extend); + SCM_VALIDATE_CHAR (1, chr); + SCM_ASSERT (SCM_FALSEP (proc) + || SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + proc, SCM_ARG2, FUNC_NAME); /* Check if chr is already in the alist. */ this = *scm_read_hash_procedures; @@ -788,20 +826,20 @@ scm_read_hash_extend (chr, proc) if (SCM_NULLP (this)) { /* not found, so add it to the beginning. */ - if (SCM_NFALSEP (proc)) + if (!SCM_FALSEP (proc)) { *scm_read_hash_procedures = scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures); } break; } - if (chr == SCM_CAAR (this)) + if (SCM_EQ_P (chr, SCM_CAAR (this))) { /* already in the alist. */ if (SCM_FALSEP (proc)) { /* remove it. */ - if (prev == SCM_BOOL_F) + if (SCM_FALSEP (prev)) { *scm_read_hash_procedures = SCM_CDR (*scm_read_hash_procedures); @@ -822,11 +860,11 @@ scm_read_hash_extend (chr, proc) return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Recover the read-hash procedure corresponding to char c. */ static SCM -scm_get_hash_procedure (c) - int c; +scm_get_hash_procedure (int c) { SCM rest = *scm_read_hash_procedures; @@ -835,7 +873,7 @@ scm_get_hash_procedure (c) if (SCM_NULLP (rest)) return SCM_BOOL_F; - if (SCM_ICHR (SCM_CAAR (rest)) == c) + if (SCM_CHAR (SCM_CAAR (rest)) == c) return SCM_CDAR (rest); rest = SCM_CDR (rest); @@ -846,8 +884,14 @@ void scm_init_read () { scm_read_hash_procedures = - SCM_CDRLOC (scm_sysintern ("read-hash-procedures", SCM_EOL)); + SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL)); scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); -#include "read.x" +#include "libguile/read.x" } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/