summaryrefslogtreecommitdiff
path: root/libguile/read.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/read.c')
-rw-r--r--libguile/read.c88
1 files changed, 36 insertions, 52 deletions
diff --git a/libguile/read.c b/libguile/read.c
index 6b85d0fc8..8b0b0b2f4 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -55,9 +55,10 @@
#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"
@@ -80,58 +81,41 @@ scm_t_option scm_read_opts[] = {
We use the format
- MESSAGE
+ 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.
- Hmmm.
-
- Maybe this is a kludge? Perhaps we should throw (list EXPR FILENAME
- LINENO COLUMNO), and have the exception handler sort out the error
- message?Where does the handler live, what are the conventions for
- the expression argument of the handler? How does this work for an
- error message like
-
-Backtrace:
-In standard input:
- 4: 0* [list ...
-
-standard input:4:1: While evaluating arguments to list in expression (list a b):standard input:4:1: Unbound variable: a
-ABORT: (unbound-variable)
-
-
-
- In any case, we would have to assemble that information anyway.
*/
-#if 0
-
-#ifndef HAVE_SNPRINTF
-#define snprintf sprintf
-/*
- should warn about buffer overflow?
- */
-#endif
+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))
+ : "#<unknown 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)));
-#define INPUT_ERROR(port, message, arg) { \
- char s[1024];\
- int fn_found = SCM_STRINGP (SCM_FILENAME(port));\
- char *fn = "";\
- if (fn_found)\
- fn = SCM_STRING_CHARS(SCM_FILENAME(port));\
- snprintf (s, 1024, "%s\nThis happened in %s%s%s line %d column %d", message, \
- fn_found ? "`" : "", \
- fn,\
- fn_found ? "'" : "", \
- SCM_LINUM(port) + 1, SCM_COL(port) + 1); \
- SCM_MISC_ERROR(s, arg); \
- }
-#else
-#define INPUT_ERROR(port, message, arg) SCM_MISC_ERROR(message, arg)
-#endif
+
+ 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,
@@ -359,7 +343,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
? scm_lreadrecparen (tok_buf, port, s_list, copy)
: scm_lreadparen (tok_buf, port, s_list, copy);
case ')':
- INPUT_ERROR(port,"unexpected \")\"", SCM_EOL);
+ scm_input_error (FUNC_NAME, port,"unexpected \")\"", SCM_EOL);
goto tryagain;
case '\'':
@@ -489,7 +473,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
if (scm_charnames[c]
&& (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf))))
return SCM_MAKE_CHAR (scm_charnums[c]);
- INPUT_ERROR (port, "unknown # object", SCM_EOL);
+ scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
/* #:SYMBOL is a syntax for keywords supported in all contexts. */
case ':':
@@ -519,7 +503,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
}
}
unkshrp:
- INPUT_ERROR (port, "Unknown # object: ~S",
+ scm_input_error (FUNC_NAME, port, "Unknown # object: ~S",
scm_list_1 (SCM_MAKE_CHAR (c)));
}
@@ -528,7 +512,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
while ('"' != (c = scm_getc (port)))
{
if (c == EOF)
- INPUT_ERROR (port, "end of file in string constant", SCM_EOL);
+ scm_input_error (FUNC_NAME, port, "end of file in string constant", SCM_EOL);
while (j + 2 >= SCM_STRING_LENGTH (*tok_buf))
scm_grow_tok_buf (tok_buf);
@@ -590,7 +574,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
c = SCM_STRING_CHARS (*tok_buf)[1];
goto callshrp;
}
- INPUT_ERROR (port, "unknown # object", SCM_EOL);
+ scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
}
goto tok;
@@ -721,7 +705,7 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
ans = scm_lreadr (tok_buf, port, copy);
closeit:
if (')' != (c = scm_flush_ws (port, name)))
- INPUT_ERROR (port, "missing close paren", SCM_EOL);
+ scm_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
return ans;
}
ans = tl = scm_cons (tmp, SCM_EOL);
@@ -761,7 +745,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
{
ans = scm_lreadr (tok_buf, port, copy);
if (')' != (c = scm_flush_ws (port, name)))
- INPUT_ERROR (port, "missing close paren", SCM_EOL);
+ scm_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
return ans;
}
/* Build the head of the list structure. */
@@ -785,7 +769,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
: tmp,
SCM_EOL));
if (')' != (c = scm_flush_ws (port, name)))
- INPUT_ERROR (port, "missing close paren", SCM_EOL);
+ scm_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
goto exit;
}