#include "extchrs.h"
#include <stdio.h>
#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"
\f
\f
-#ifdef READER_EXTENSIONS
scm_option scm_read_opts[] = {
- { SCM_OPTION_BOOLEAN, "positions", 0 },
- { SCM_OPTION_BOOLEAN, "copy", 0 }
+ { SCM_OPTION_BOOLEAN, "copy", 0,
+ "Copy source code expressions." },
+ { SCM_OPTION_BOOLEAN, "positions", 0,
+ "Record positions of source code expressions." }
};
-SCM_PROC (s_read_options, "read-options", 0, 1, 0, scm_read_options);
-#ifdef __STDC__
-SCM
-scm_read_options (SCM new_values)
-#else
+SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options);
+
SCM
-scm_read_options (new_values)
- SCM new_values;
-#endif
+scm_read_options (setting)
+ SCM setting;
{
- SCM ans = scm_change_options (new_values,
- scm_read_opts,
- N_READ_OPTIONS,
- s_read_options);
- if (COPY_SOURCE)
- RECORD_POSITIONS = 1;
+ SCM ans = scm_options (setting,
+ scm_read_opts,
+ SCM_N_READ_OPTIONS,
+ s_read_options);
+ if (SCM_COPY_SOURCE_P)
+ SCM_RECORD_POSITIONS_P = 1;
return ans;
}
-#endif
SCM_PROC (s_read, "read", 0, 3, 0, scm_read);
-#ifdef __STDC__
-SCM
-scm_read (SCM port, SCM case_insensitive_p, SCM sharp)
-#else
+
SCM
scm_read (port, case_insensitive_p, sharp)
SCM port;
SCM case_insensitive_p;
SCM sharp;
-#endif
{
int c;
- SCM tok_buf;
+ SCM tok_buf, copy;
int case_i;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
+ port,
+ SCM_ARG1,
+ s_read);
case_i = (SCM_UNBNDP (case_insensitive_p)
? default_case_i
scm_gen_ungetc (c, port);
tok_buf = scm_makstr (30L, 0);
- return scm_lreadr (&tok_buf, port, case_i, sharp);
+ return scm_lreadr (&tok_buf, port, case_i, sharp, ©);
}
-#ifdef __STDC__
-char *
-scm_grow_tok_buf (SCM * tok_buf)
-#else
+
char *
scm_grow_tok_buf (tok_buf)
SCM * tok_buf;
-#endif
{
- SCM t2;
- scm_sizet len;
-
- len = SCM_LENGTH (*tok_buf);
- len += (len / 2 ? len / 2 : 1);
- t2 = scm_makstr (len, 0);
- {
- char * a;
- char * b;
- int l;
- for (a = SCM_CHARS (*tok_buf), b = SCM_CHARS (t2), l = SCM_LENGTH (*tok_buf);
- l;
- --l, ++a, ++b)
- *b = *a;
- }
- *tok_buf = t2;
+ scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf)));
return SCM_CHARS (*tok_buf);
}
-#ifdef __STDC__
-int
-scm_flush_ws (SCM port, char *eoferr)
-#else
+
int
scm_flush_ws (port, eoferr)
SCM port;
char *eoferr;
-#endif
{
register int c;
while (1)
}
break;
case SCM_LINE_INCREMENTORS:
- break;
case SCM_SINGLE_SPACES:
- SCM_INCCOL (port);
- break;
case '\t':
- SCM_TABCOL (port);
break;
default:
return c;
}
-#ifdef __STDC__
-int
-scm_casei_streq (char * s1, char * s2)
-#else
+
int
scm_casei_streq (s1, s2)
char * s1;
char * s2;
-#endif
{
while (*s1 && *s2)
if (scm_downcase((int)*s1) != scm_downcase((int)*s2))
}
-#ifdef __STDC__
-SCM
-scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp)
-#else
+/* recsexpr is used when recording expressions
+ * constructed by read:sharp.
+ */
+
+static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename));
+
+static SCM
+recsexpr (obj, line, column, filename)
+ SCM obj;
+ int line;
+ int column;
+ SCM filename;
+{
+ if (SCM_IMP (obj) || SCM_NCONSP(obj))
+ return obj;
+ {
+ 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
+ which haven't previously been read by the reader. */
+ if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj)))
+ {
+ if (SCM_COPY_SOURCE_P)
+ {
+ copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
+ SCM_UNDEFINED);
+ while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
+ {
+ SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
+ line,
+ column,
+ filename),
+ SCM_UNDEFINED));
+ copy = SCM_CDR (copy);
+ }
+ SCM_SETCDR (copy, tmp);
+ }
+ else
+ {
+ recsexpr (SCM_CAR (obj), line, column, filename);
+ while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
+ recsexpr (SCM_CAR (tmp), line, column, filename);
+ copy = SCM_UNDEFINED;
+ }
+ scm_whash_insert (scm_source_whash,
+ obj,
+ scm_make_srcprops (line,
+ column,
+ filename,
+ copy,
+ SCM_EOL));
+ }
+ return obj;
+ }
+}
+
+
+/* Consume an SCSH-style block comment. Assume that we've already
+ read the initial `#!', and eat characters until the matching `!#'. */
+
+static void
+skip_scsh_block_comment (port)
+ SCM port;
+{
+ char last_c = '\0';
+
+ for (;;)
+ {
+ int c = scm_gen_getc (port);
+
+ if (c == EOF)
+ scm_wta (SCM_UNDEFINED,
+ "unterminated `#! ... !#' comment", "read");
+ else if (c == '#' && last_c == '!')
+ return;
+
+ last_c = c;
+ }
+}
+
+
+static char s_list[]="list";
+
SCM
-scm_lreadr (tok_buf, port, case_i, sharp)
- SCM * tok_buf;
+scm_lreadr (tok_buf, port, case_i, sharp, copy)
+ SCM *tok_buf;
SCM port;
int case_i;
SCM sharp;
-#endif
+ SCM *copy;
{
int c;
scm_sizet j;
tryagain:
c = scm_flush_ws (port, s_read);
+tryagain_no_flush_ws:
switch (c)
{
case EOF:
return SCM_EOF_VAL;
case '(':
- return scm_lreadparen (tok_buf, port, "list", case_i, sharp);
-
+ return SCM_RECORD_POSITIONS_P
+ ? scm_lreadrecparen (tok_buf, port, s_list, case_i, sharp, copy)
+ : scm_lreadparen (tok_buf, port, s_list, case_i, sharp, copy);
case ')':
scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
goto tryagain;
case '\'':
- return scm_cons2 (scm_i_quote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ p = scm_i_quote;
+ goto recquote;
case '`':
- return scm_cons2 (scm_i_quasiquote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ p = scm_i_quasiquote;
+ goto recquote;
case ',':
c = scm_gen_getc (port);
if ('@' == c)
scm_gen_ungetc (c, port);
p = scm_i_unquote;
}
- return scm_cons2 (p, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ recquote:
+ p = scm_cons2 (p,
+ scm_lreadr (tok_buf, port, case_i, sharp, copy),
+ SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash,
+ p,
+ scm_make_srcprops (SCM_LINUM (port),
+ SCM_COL (port) - 1,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (*copy = scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+ return p;
case '#':
c = scm_gen_getc (port);
switch (c)
{
case '(':
- p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp);
+ p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp, copy);
return SCM_NULLP (p) ? scm_nullvect : scm_vector (p);
case 't':
c = '#';
goto num;
+ case '!':
+ /* start of a shell script. Parse as a block comment,
+ terminated by !#, just like SCSH. */
+ skip_scsh_block_comment (port);
+ /* EOF is not an error here */
+ c = scm_flush_ws (port, (char *)NULL);
+ goto tryagain_no_flush_ws;
+
case '*':
j = scm_read_token (c, tok_buf, port, case_i, 0);
p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1));
callshrp:
if (SCM_NIMP (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));
+ got = scm_apply (sharp,
+ SCM_MAKICHR (c),
+ scm_acons (port, SCM_EOL, SCM_EOL));
if (SCM_UNSPECIFIED == got)
goto unkshrp;
- return got;
+ if (SCM_RECORD_POSITIONS_P)
+ return *copy = recsexpr (got, line, column,
+ SCM_FILENAME (port));
+ else
+ return got;
}
- unkshrp:scm_wta ((SCM) SCM_MAKICHR (c), "unknown # object", "");
+ unkshrp:
+ scm_misc_error (s_read, "Unknown # object: %S",
+ scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED));
}
case '"':
#ifdef _UNICOS
_Pragma ("noopt"); /* # pragma _CRI noopt */
#endif
-#ifdef __STDC__
-scm_sizet
-scm_read_token (int ic, SCM * tok_buf, SCM port, int case_i, int weird)
-#else
+
scm_sizet
-scm_read_token (ic, * tok_buf, port, case_i, weird)
+scm_read_token (ic, tok_buf, port, case_i, weird)
int ic;
SCM *tok_buf;
SCM port;
int case_i;
int weird;
-#endif
{
register scm_sizet j;
register int c;
}
}
}
+
#ifdef _UNICOS
_Pragma ("opt"); /* # pragma _CRI opt */
#endif
-#ifdef __STDC__
-SCM
-scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp)
-#else
SCM
-scm_lreadparen (tok_buf, port, name, case_i, sharp)
+scm_lreadparen (tok_buf, port, name, case_i, sharp, copy)
SCM *tok_buf;
SCM port;
char *name;
int case_i;
SCM sharp;
-#endif
+ SCM *copy;
{
SCM tmp;
SCM tl;
if (')' == c)
return SCM_EOL;
scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp)))
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
{
- ans = scm_lreadr (tok_buf, port, case_i, sharp);
+ ans = scm_lreadr (tok_buf, port, case_i, sharp, copy);
closeit:
if (')' != (c = scm_flush_ws (port, name)))
scm_wta (SCM_UNDEFINED, "missing close paren", "");
while (')' != (c = scm_flush_ws (port, name)))
{
scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp)))
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
{
- SCM_CDR (tl) = scm_lreadr (tok_buf, port, case_i, sharp);
+ SCM_SETCDR (tl, scm_lreadr (tok_buf, port, case_i, sharp, copy));
goto closeit;
}
- tl = (SCM_CDR (tl) = scm_cons (tmp, SCM_EOL));
+ SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
+ tl = SCM_CDR (tl);
+ }
+ return ans;
+}
+
+
+SCM
+scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy)
+ SCM *tok_buf;
+ SCM port;
+ char *name;
+ int case_i;
+ SCM sharp;
+ SCM *copy;
+{
+ register int c;
+ register SCM tmp;
+ register SCM tl, tl2 = SCM_EOL;
+ SCM ans, ans2 = SCM_EOL;
+ /* Need to capture line and column numbers here. */
+ int line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ 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, case_i, sharp, copy)))
+ {
+ ans = scm_lreadr (tok_buf, port, case_i, sharp, copy);
+ if (')' != (c = scm_flush_ws (port, name)))
+ scm_wta (SCM_UNDEFINED, "missing close paren", "");
+ 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)
+ ? *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, case_i, sharp, copy)))
+ {
+ SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy));
+ if (SCM_COPY_SOURCE_P)
+ SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL));
+ if (')' != (c = scm_flush_ws (port, name)))
+ scm_wta (SCM_UNDEFINED, "missing close paren", "");
+ goto exit;
+ }
+ tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
+ if (SCM_COPY_SOURCE_P)
+ tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL));
}
+exit:
+ scm_whash_insert (scm_source_whash,
+ ans,
+ scm_make_srcprops (line,
+ column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? *copy = ans2
+ : SCM_UNDEFINED,
+ SCM_EOL));
return ans;
}
\f
-#ifdef __STDC__
-void
-scm_init_read (void)
-#else
+
void
scm_init_read ()
-#endif
{
-#ifdef READER_EXTENSIONS
- scm_init_opts (scm_read_options, scm_read_opts, N_READ_OPTIONS);
-#endif
+ scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
#include "read.x"
}
-
HCoop / bpt / guile.git / blobdiff