From deca31e1736a487104ecde76df8b55be18c1ef65 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sat, 8 Mar 1997 18:58:24 +0000 Subject: [PATCH] * strports.c (scm_read_0str, scm_eval_0str): update scm_read usage. * gdbint.c (gdb_read): update scm_lreadr usage. * load.h: update prototypes. * load.c (scm_primitive_load, scm_read_and_eval_x, scm_primitive_load_path): remove case_insensitive_p, sharp arguments. * read.h: add prototype for scm_read_hash_extend. Change args for other prototypes. * read.c (scm_read_hash_procedures): new variable. (scm_read_hash_extend): new procedure. (scm_get_hash_procedure): new procedure. * (scm_lreadr): use scm_get_hash_procedure instead of an argument for extended # processing. (scm_read, scm_lreadr, scm_lreadrecparen, scm_lreadparen, scm_read_token): remove case_i, sharp arguments. Change callers. * read.h (SCM_N_READ_OPTIONS): increase to 3. (SCM_CASE_INSENSITIVE_P): define. * read.c: add case-insensitive option to scm_read_opts. * (scm_read_token): use SCM_CASE_INSENSITIVE_P instead of an argument to determine whether to convert symbol case. (default_case_i): definition removed. * read.c (scm_read_token): if case_i, downcase ic before doing anything with it. --- libguile/ChangeLog | 34 ++++++++++ libguile/gdbint.c | 2 +- libguile/load.c | 24 +++---- libguile/load.h | 9 +-- libguile/read.c | 160 ++++++++++++++++++++++++++------------------ libguile/read.h | 14 ++-- libguile/strports.c | 4 +- 7 files changed, 151 insertions(+), 96 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 98ffe3b31..6c2e8b8ef 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +Sat Mar 8 00:27:05 1997 Gary Houston + + * strports.c (scm_read_0str, scm_eval_0str): update scm_read usage. + + * gdbint.c (gdb_read): update scm_lreadr usage. + + * load.h: update prototypes. + + * load.c (scm_primitive_load, scm_read_and_eval_x, + scm_primitive_load_path): remove case_insensitive_p, sharp arguments. + + * read.h: add prototype for scm_read_hash_extend. Change args for + other prototypes. + + * read.c (scm_read_hash_procedures): new variable. + (scm_read_hash_extend): new procedure. + (scm_get_hash_procedure): new procedure. +* (scm_lreadr): use scm_get_hash_procedure instead of an argument + for extended # processing. + (scm_read, scm_lreadr, scm_lreadrecparen, scm_lreadparen, + scm_read_token): remove case_i, sharp arguments. Change callers. + +Fri Mar 7 08:58:21 1997 Gary Houston + + * read.h (SCM_N_READ_OPTIONS): increase to 3. + (SCM_CASE_INSENSITIVE_P): define. + + * read.c: add case-insensitive option to scm_read_opts. +* (scm_read_token): use SCM_CASE_INSENSITIVE_P instead of an argument + to determine whether to convert symbol case. + (default_case_i): definition removed. + * read.c (scm_read_token): if case_i, downcase ic before doing + anything with it. + Sat Mar 8 03:49:03 1997 Mikael Djurfeldt * configure.in: Added configuration option `guile-debug'. diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 3ce4f2eca..4879723d7 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -215,7 +215,7 @@ gdb_read (str) /* Read one object */ tok_buf_mark_p = SCM_GC8MARKP (tok_buf); SCM_CLRGC8MARK (tok_buf); - ans = scm_lreadr (&tok_buf, gdb_input_port, 0, SCM_BOOL_F, &ans); + ans = scm_lreadr (&tok_buf, gdb_input_port, &ans); if (SCM_GC_P) { if (SCM_NIMP (ans)) diff --git a/libguile/load.c b/libguile/load.c index b9a9fc8cc..04ee995ed 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -68,12 +68,10 @@ Applied to the full name of the file. */ static SCM *scm_loc_load_hook; -SCM_PROC(s_primitive_load, "primitive-load", 1, 2, 0, scm_primitive_load); +SCM_PROC(s_primitive_load, "primitive-load", 1, 0, 0, scm_primitive_load); SCM -scm_primitive_load (filename, case_insensitive_p, sharp) +scm_primitive_load (filename) SCM filename; - SCM case_insensitive_p; - SCM sharp; { SCM hook = *scm_loc_load_hook; SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, @@ -92,7 +90,7 @@ scm_primitive_load (filename, case_insensitive_p, sharp) scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); while (1) { - form = scm_read (port, case_insensitive_p, sharp); + form = scm_read (port); if (SCM_EOF_VAL == form) break; scm_eval_x (form); @@ -277,12 +275,10 @@ scm_sys_search_load_path (filename) } -SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 2, 0, scm_primitive_load_path); +SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_primitive_load_path); SCM -scm_primitive_load_path (filename, case_insensitive_p, sharp) +scm_primitive_load_path (filename) SCM filename; - SCM case_insensitive_p; - SCM sharp; { SCM full_filename; @@ -302,7 +298,7 @@ scm_primitive_load_path (filename, case_insensitive_p, sharp) scm_listify (filename, SCM_UNDEFINED)); } - return scm_primitive_load (full_filename, case_insensitive_p, sharp); + return scm_primitive_load (full_filename); } /* The following function seems trivial - and indeed it is. Its @@ -312,15 +308,13 @@ scm_primitive_load_path (filename, case_insensitive_p, sharp) SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); -SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 3, 0, scm_read_and_eval_x); +SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 1, 0, scm_read_and_eval_x); SCM -scm_read_and_eval_x (port, case_insensitive_p, sharp) +scm_read_and_eval_x (port) SCM port; - SCM case_insensitive_p; - SCM sharp; { - SCM form = scm_read (port, case_insensitive_p, sharp); + SCM form = scm_read (port); if (form == SCM_EOF_VAL) scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); return scm_eval_x (form); diff --git a/libguile/load.h b/libguile/load.h index cd5d021bb..93db7fdbb 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -47,14 +47,11 @@ extern void scm_init_load_path SCM_P ((void)); -extern SCM scm_primitive_load SCM_P ((SCM filename, SCM casep, SCM sharp)); +extern SCM scm_primitive_load SCM_P ((SCM filename)); extern SCM scm_sys_package_data_dir SCM_P ((void)); extern SCM scm_sys_search_load_path SCM_P ((SCM filename)); -extern SCM scm_primitive_load_path SCM_P ((SCM filename, SCM casep, - SCM sharp)); -extern SCM scm_read_and_eval_x SCM_P ((SCM port, - SCM case_insensitive_p, - SCM sharp)); +extern SCM scm_primitive_load_path SCM_P ((SCM filename)); +extern SCM scm_read_and_eval_x SCM_P ((SCM port)); extern void scm_init_load SCM_P ((void)); #endif /* LOADH */ diff --git a/libguile/read.c b/libguile/read.c index dc04c34d0..ca7614df0 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -58,15 +58,13 @@ -#define default_case_i 0 - - - scm_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "copy", 0, "Copy source code expressions." }, { SCM_OPTION_BOOLEAN, "positions", 0, - "Record positions of source code expressions." } + "Record positions of source code expressions." }, + { SCM_OPTION_BOOLEAN, "case-insensitive", 0, + "Convert symbols to lower case."} }; SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options); @@ -84,17 +82,17 @@ scm_read_options (setting) return ans; } -SCM_PROC (s_read, "read", 0, 3, 0, scm_read); +/* Association list mapping extra hash characters to procedures. */ +static SCM scm_read_hash_procedures = SCM_EOL; + +SCM_PROC (s_read, "read", 0, 1, 0, scm_read); SCM -scm_read (port, case_insensitive_p, sharp) +scm_read (port) SCM port; - SCM case_insensitive_p; - SCM sharp; { int c; SCM tok_buf, copy; - int case_i; if (SCM_UNBNDP (port)) port = scm_cur_inp; @@ -104,20 +102,13 @@ scm_read (port, case_insensitive_p, sharp) SCM_ARG1, s_read); - case_i = (SCM_UNBNDP (case_insensitive_p) - ? default_case_i - : (case_insensitive_p == SCM_BOOL_F)); - - if (SCM_UNBNDP (sharp)) - sharp = SCM_BOOL_F; - c = scm_flush_ws (port, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; 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, ©); } @@ -266,21 +257,21 @@ skip_scsh_block_comment (port) } } +static SCM +scm_get_hash_procedure SCM_P ((int c)); static char s_list[]="list"; SCM -scm_lreadr (tok_buf, port, case_i, sharp, copy) +scm_lreadr (tok_buf, port, copy) SCM *tok_buf; SCM port; - int case_i; - SCM sharp; SCM *copy; { int c; scm_sizet j; SCM p; - + tryagain: c = scm_flush_ws (port, s_read); tryagain_no_flush_ws: @@ -291,8 +282,8 @@ tryagain_no_flush_ws: case '(': 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); + ? scm_lreadrecparen (tok_buf, port, s_list, copy) + : scm_lreadparen (tok_buf, port, s_list, copy); case ')': scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); goto tryagain; @@ -314,7 +305,7 @@ tryagain_no_flush_ws: } recquote: p = scm_cons2 (p, - scm_lreadr (tok_buf, port, case_i, sharp, copy), + scm_lreadr (tok_buf, port, copy), SCM_EOL); if (SCM_RECORD_POSITIONS_P) scm_whash_insert (scm_source_whash, @@ -334,7 +325,7 @@ tryagain_no_flush_ws: switch (c) { case '(': - p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp, copy); + p = scm_lreadparen (tok_buf, port, "vector", copy); return SCM_NULLP (p) ? scm_nullvect : scm_vector (p); case 't': @@ -369,7 +360,7 @@ tryagain_no_flush_ws: goto tryagain_no_flush_ws; case '*': - j = scm_read_token (c, tok_buf, port, case_i, 0); + j = scm_read_token (c, tok_buf, port, 0); p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1)); if (SCM_NFALSEP (p)) return p; @@ -377,7 +368,7 @@ tryagain_no_flush_ws: goto unkshrp; case '{': - j = scm_read_token (c, tok_buf, port, case_i, 1); + 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); @@ -385,7 +376,7 @@ tryagain_no_flush_ws: case '\\': c = scm_gen_getc (port); - j = scm_read_token (c, tok_buf, port, case_i, 0); + j = scm_read_token (c, tok_buf, port, 0); if (j == 1) return SCM_MAKICHR (c); if (c >= '0' && c < '8') @@ -403,22 +394,27 @@ tryagain_no_flush_ws: default: 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)); - if (SCM_UNSPECIFIED == got) - goto unkshrp; - if (SCM_RECORD_POSITIONS_P) - return *copy = recsexpr (got, line, column, - SCM_FILENAME (port)); - else - return got; - } + { + SCM sharp = scm_get_hash_procedure (c); + + 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)); + if (SCM_UNSPECIFIED == got) + goto unkshrp; + if (SCM_RECORD_POSITIONS_P) + return *copy = recsexpr (got, line, column, + SCM_FILENAME (port)); + else + return got; + } + } unkshrp: scm_misc_error (s_read, "Unknown # object: %S", scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED)); @@ -494,7 +490,7 @@ tryagain_no_flush_ws: case '-': case '+': num: - j = scm_read_token (c, tok_buf, port, case_i, 0); + j = scm_read_token (c, tok_buf, port, 0); p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L); if (SCM_NFALSEP (p)) return p; @@ -511,14 +507,14 @@ tryagain_no_flush_ws: goto tok; case ':': - j = scm_read_token ('-', tok_buf, port, case_i, 0); + 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)); default: - j = scm_read_token (c, tok_buf, port, case_i, 0); + j = scm_read_token (c, tok_buf, port, 0); /* fallthrough */ tok: @@ -534,18 +530,17 @@ _Pragma ("noopt"); /* # pragma _CRI noopt */ #endif scm_sizet -scm_read_token (ic, tok_buf, port, case_i, weird) +scm_read_token (ic, tok_buf, port, weird) int ic; SCM *tok_buf; SCM port; - int case_i; int weird; { register scm_sizet j; register int c; register char *p; - c = ic; + c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(ic) : ic); p = SCM_CHARS (*tok_buf); if (weird) @@ -623,7 +618,7 @@ scm_read_token (ic, tok_buf, port, case_i, weird) default: default_case: { - c = (case_i ? scm_downcase(c) : c); + c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(c) : c); if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) { p[j] = c; @@ -649,12 +644,10 @@ _Pragma ("opt"); /* # pragma _CRI opt */ #endif SCM -scm_lreadparen (tok_buf, port, name, case_i, sharp, copy) +scm_lreadparen (tok_buf, port, name, copy) SCM *tok_buf; SCM port; char *name; - int case_i; - SCM sharp; SCM *copy; { SCM tmp; @@ -666,9 +659,9 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp, copy) if (')' == c) return SCM_EOL; scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) + if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) { - ans = scm_lreadr (tok_buf, port, case_i, sharp, copy); + ans = scm_lreadr (tok_buf, port, copy); closeit: if (')' != (c = scm_flush_ws (port, name))) scm_wta (SCM_UNDEFINED, "missing close paren", ""); @@ -678,9 +671,9 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp, copy) 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))) + if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) { - SCM_SETCDR (tl, scm_lreadr (tok_buf, port, case_i, sharp, copy)); + SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy)); goto closeit; } SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); @@ -691,12 +684,10 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp, copy) SCM -scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy) +scm_lreadrecparen (tok_buf, port, name, copy) SCM *tok_buf; SCM port; char *name; - int case_i; - SCM sharp; SCM *copy; { register int c; @@ -711,9 +702,9 @@ scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy) if (')' == c) return SCM_EOL; scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) + if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) { - ans = scm_lreadr (tok_buf, port, case_i, sharp, copy); + ans = scm_lreadr (tok_buf, port, copy); if (')' != (c = scm_flush_ws (port, name))) scm_wta (SCM_UNDEFINED, "missing close paren", ""); return ans; @@ -728,9 +719,9 @@ scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy) 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))) + if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) { - SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, case_i, sharp, 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) ? *copy @@ -763,7 +754,44 @@ exit: +/* Register a procedure for extended # object processing and the character + that will trigger it. */ +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_ASSERT (SCM_ICHRP(chr), chr, SCM_ARG1, s_read_hash_extend); + SCM_ASSERT (SCM_NIMP(proc), proc, SCM_ARG2, s_read_hash_extend); + /* We are making every member of this list a permanent object. + Is that bad? */ + SCM_DEFER_INTS; + scm_read_hash_procedures = scm_cons (scm_cons (chr, proc), + scm_read_hash_procedures); + scm_permanent_object (scm_read_hash_procedures); + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; +} + +/* Recover the read-hash procedure corresponding to char c. */ +static SCM +scm_get_hash_procedure (c) + int c; +{ + SCM rest = scm_read_hash_procedures; + while (1) + { + if (SCM_NULLP (rest)) + return SCM_BOOL_F; + + if (SCM_ICHR (SCM_CAAR (rest)) == c) + return SCM_CDAR (rest); + + rest = SCM_CDR (rest); + } +} void scm_init_read () diff --git a/libguile/read.h b/libguile/read.h index 8eef1ed24..74904452b 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -71,19 +71,21 @@ extern scm_option scm_read_opts[]; #define SCM_COPY_SOURCE_P scm_read_opts[0].val #define SCM_RECORD_POSITIONS_P scm_read_opts[1].val -#define SCM_N_READ_OPTIONS 2 +#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val +#define SCM_N_READ_OPTIONS 3 extern SCM scm_read_options SCM_P ((SCM setting)); -extern SCM scm_read SCM_P ((SCM port, SCM casep, SCM sharp)); +extern SCM scm_read SCM_P ((SCM port)); extern char * scm_grow_tok_buf SCM_P ((SCM * tok_buf)); extern int scm_flush_ws SCM_P ((SCM port, char *eoferr)); extern int scm_casei_streq SCM_P ((char * s1, char * s2)); -extern SCM scm_lreadr SCM_P ((SCM * tok_buf, SCM port, int case_i, SCM sharp, SCM *copy)); -extern scm_sizet scm_read_token SCM_P ((int ic, SCM * tok_buf, SCM port, int case_i, int weird)); -extern SCM scm_lreadparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)); -extern SCM scm_lreadrecparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)); +extern SCM scm_lreadr SCM_P ((SCM * tok_buf, SCM port, SCM *copy)); +extern scm_sizet scm_read_token SCM_P ((int ic, SCM * tok_buf, SCM port, int weird)); +extern SCM scm_lreadparen SCM_P ((SCM * tok_buf, SCM port, char *name, SCM *copy)); +extern SCM scm_lreadrecparen SCM_P ((SCM * tok_buf, SCM port, char *name, SCM *copy)); +extern SCM scm_read_hash_extend SCM_P ((SCM chr, SCM proc)); extern void scm_init_read SCM_P ((void)); #endif /* READH */ diff --git a/libguile/strports.c b/libguile/strports.c index 3518c9cff..34485f0b3 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -242,7 +242,7 @@ scm_read_0str (expr) SCM form; /* Read expressions from that port; ignore the values. */ - form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F); + form = scm_read (port); scm_close_port (port); return form; @@ -262,7 +262,7 @@ scm_eval_0str (expr) SCM ans = SCM_EOL; /* Read expressions from that port; ignore the values. */ - while ((form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F)) != SCM_EOF_VAL) + while ((form = scm_read (port)) != SCM_EOF_VAL) ans = scm_eval_x (form); scm_close_port (port);