From 0e89f235c40124b1958fdd7d660aaf81be0220fc Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Fri, 19 Jun 2009 11:12:49 +0200 Subject: [PATCH] Implement read-only readtables to avoid copying the standard readtable when this value is requested. --- src/CHANGELOG | 10 +++++++++ src/c/read.d | 48 ++++++++++++++++++++++++++++++++++++------ src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/clx/dependent.lisp | 4 ++-- src/h/external.h | 1 + src/h/object.h | 2 +- src/lsp/export.lsp | 3 ++- src/lsp/iolib.lsp | 2 +- 9 files changed, 63 insertions(+), 11 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 47d5ea038..12a25d7be 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1,3 +1,13 @@ +ECL 9.6.3: +========== + +* Printer: + + - Readtables have a new flag that makes them read-only. Function + (si::readtable-lock readtable &optional new-flag) + either reads the state of this flag (if NEW-FLAG is missing) or + also sets it. + ECL 9.6.2: ========== diff --git a/src/c/read.d b/src/c/read.d index 1f010d2ca..06c3113bc 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1427,6 +1427,7 @@ ecl_copy_readtable(cl_object from, cl_object to) * at the end in a more or less "atomic" (meaning "fast") way. */ output = ecl_alloc_object(t_readtable); + output->readtable.locked = 0; output->readtable.table = to_rtab = (struct ecl_readtable_entry *) ecl_alloc_align(total_bytes, entry_bytes); from_rtab = from->readtable.table; @@ -1463,8 +1464,7 @@ ecl_current_readtable(void) /* INV: *readtable* always has a value */ r = ECL_SYM_VAL(the_env, @'*readtable*'); if (type_of(r) != t_readtable) { - ECL_SETQ(the_env, @'*readtable*', - ecl_copy_readtable(cl_core.standard_readtable, Cnil)); + ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); FEerror("The value of *READTABLE*, ~S, was not a readtable.", 1, r); } @@ -1867,10 +1867,22 @@ cl_readtable_case(cl_object r) @(return r) } +static void +error_locked_readtable(cl_object r) +{ + cl_error(3, + make_constant_base_string("Change readtable"), + make_constant_base_string("Cannot modify locked readtable ~A."), + r); +} + cl_object si_readtable_case_set(cl_object r, cl_object mode) { assert_type_readtable(r); + if (r->readtable.locked) { + error_locked_readtable(r); + } if (mode == @':upcase') { r->readtable.read_case = ecl_case_upcase; } else if (mode == @':downcase') { @@ -1929,6 +1941,9 @@ void ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, cl_object macro_or_table) { + if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } #ifdef ECL_UNICODE if (c >= RTABSIZE) { cl_object hash = readtable->readtable.hash; @@ -1962,6 +1977,9 @@ ecl_invalid_character_p(int c) cl_object dispatch; cl_fixnum fc, tc; @ + if (tordtbl->readtable.locked) { + error_locked_readtable(tordtbl); + } if (Null(fromrdtbl)) fromrdtbl = cl_core.standard_readtable; assert_type_readtable(fromrdtbl); @@ -2024,6 +2042,9 @@ ecl_invalid_character_p(int c) @ assert_type_readtable(readtable); ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); + if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } if (type_of(table) != t_hashtable) { FEerror("~S is not a dispatch character.", 1, dspchr); } @@ -2095,6 +2116,17 @@ si_standard_readtable() @(return cl_core.standard_readtable) } +@(defun ext::readtable-lock (r &optional yesno) + cl_object output; +@ + assert_type_readtable(r); + output = (r->readtable.locked)? Ct : Cnil; + if (narg > 1) { + r->readtable.locked = !Null(yesno); + } + @(return output) +@) + static void extra_argument(int c, cl_object stream, cl_object d) { @@ -2114,9 +2146,9 @@ init_read(void) int i; cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); - cl_core.standard_readtable->readtable.read_case = ecl_case_upcase; - cl_core.standard_readtable->readtable.table - = rtab + r->readtable.locked = 0; + r->readtable.read_case = ecl_case_upcase; + r->readtable.table = rtab = (struct ecl_readtable_entry *) ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); for (i = 0; i < RTABSIZE; i++) { @@ -2124,7 +2156,7 @@ init_read(void) rtab[i].dispatch = Cnil; } #ifdef ECL_UNICODE - cl_core.standard_readtable->readtable.hash = Cnil; + r->readtable.hash = Cnil; #endif cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); @@ -2205,6 +2237,10 @@ init_read(void) cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('Y'), make_cf3(sharp_Y_reader), r); + /* Lock the standard read table so that we do not have to make copies + * to keep it unchanged */ + r->readtable.locked = 1; + init_backq(); ECL_SET(@'*readtable*', diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 3a27f6ce5..caa0ccfc8 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1788,5 +1788,7 @@ cl_symbols[] = { {EXT_ "OUTPUT-FLOAT-NAN", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "OUTPUT-FLOAT-INFINITY", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "READTABLE-LOCK", EXT_ORDINARY, si_readtable_lock, -1, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 5af3f43b4..868f77cf9 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1788,5 +1788,7 @@ cl_symbols[] = { {EXT_ "OUTPUT-FLOAT-NAN",NULL}, {EXT_ "OUTPUT-FLOAT-INFINITY",NULL}, +{EXT_ "READTABLE-LOCK","si_readtable_lock"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp index 2f38f14c1..cb33f3e41 100644 --- a/src/clx/dependent.lisp +++ b/src/clx/dependent.lisp @@ -3007,7 +3007,7 @@ Returns a list of (host display-number screen protocol)." ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) ;;----------------------------------------------------------------------------- -#-(or clx-ansi-common-lisp Genera CMU sbcl) +#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) (defun with-standard-io-syntax-function (function) (declare #+lispm (sys:downward-funarg function)) @@ -3029,7 +3029,7 @@ Returns a list of (host display-number screen protocol)." #+lucid (lucid::*print-structure* t)) (funcall function))) -#-(or clx-ansi-common-lisp Genera CMU sbcl) +#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) (defmacro with-standard-io-syntax (&body body) `(flet ((.with-standard-io-syntax-body. () ,@body)) (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) diff --git a/src/h/external.h b/src/h/external.h index 239e4a011..a6673927b 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -1354,6 +1354,7 @@ extern ECL_API cl_object cl_make_dispatch_macro_character _ARGS((cl_narg narg, c extern ECL_API cl_object cl_set_dispatch_macro_character _ARGS((cl_narg narg, cl_object dspchr, cl_object subchr, cl_object fnc, ...)); extern ECL_API cl_object cl_get_dispatch_macro_character _ARGS((cl_narg narg, cl_object dspchr, cl_object subchr, ...)); extern ECL_API cl_object si_read_object_or_ignore(cl_object stream, cl_object eof); +extern ECL_API cl_object si_readtable_lock _ARGS((cl_narg narg, cl_object readtable, ...)); extern ECL_API int ecl_readtable_get(cl_object rdtbl, int c, cl_object *macro); extern ECL_API void ecl_readtable_set(cl_object rdtbl, int c, enum ecl_chattrib cat, cl_object macro_or_table); diff --git a/src/h/object.h b/src/h/object.h index 8f758ae72..3e0488cf7 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -626,7 +626,7 @@ enum ecl_readtable_case { }; struct ecl_readtable { /* read table */ - HEADER; + HEADER1(locked); enum ecl_readtable_case read_case; /* readtable-case */ struct ecl_readtable_entry *table; /* read table itself */ #ifdef ECL_UNICODE diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index 7fe112cc0..495c6c8e6 100644 --- a/src/lsp/export.lsp +++ b/src/lsp/export.lsp @@ -173,8 +173,9 @@ (defun sharp---reader (stream subchar arg) (do-read-feature stream subchar arg NIL)) +(si::readtable-lock (si::standard-readtable) nil) (set-dispatch-macro-character #\# #\+ 'sharp-+-reader) (set-dispatch-macro-character #\# #\+ 'sharp-+-reader (sys::standard-readtable)) - (set-dispatch-macro-character #\# #\- 'sharp---reader) (set-dispatch-macro-character #\# #\- 'sharp---reader (sys::standard-readtable)) +(si::readtable-lock (si::standard-readtable) t) diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp index f0c62520c..b56591142 100644 --- a/src/lsp/iolib.lsp +++ b/src/lsp/iolib.lsp @@ -255,7 +255,7 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) - (*readtable* (copy-readtable (si::standard-readtable)))) + (*readtable* (si::standard-readtable))) ,@body)) #-formatter