Implement read-only readtables to avoid copying the standard readtable when this value is requested.

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:
 ==========
 

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*',

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}};

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}};

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.)))

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);

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

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)

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