Plaster

diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index a05ba0b19..c7775b63b 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -163,6 +163,23 @@ Example: @include fun-sb-ext-add-package-local-nickname.texinfo @include fun-sb-ext-remove-package-local-nickname.texinfo +@subsection Reader Symbol Interning Customization +@cindex Reader Symbol Interning Customization +@cindex Symbols, interning +@tindex @cl{intern} + +SBCL supports providing a custom @code{intern} function for the +reader. If @code{*read-intern*} is set to a function-designator, the +reader will call it with the string and package of the symbol it is +trying to @code{intern}. The function should return the value to be +read, which would usually be a symbol. + +@vindex @cl{@earmuffs{read-intern}} +@tindex @cl{function-designator} +@findex @cl{read} +@findex @cl{read-from-string} +In addition, @code{with-standard-io-syntax} will bind @code{*read-intern*} to @code{nil}. + @node Package Variance @comment node-name, next, previous, up @section Package Variance diff --git a/src/code/ansi-stream.lisp b/src/code/ansi-stream.lisp index 9915371e9..5e03f5efe 100644 --- a/src/code/ansi-stream.lisp +++ b/src/code/ansi-stream.lisp @@ -218,6 +218,7 @@ *READTABLE* the standard readtable SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL SB-EXT:*PRINT-VECTOR-LENGTH* NIL + SB-EXT:*READ-INTERN* NIL " (let ((name (make-symbol "THUNK"))) `(dx-flet ((,name () ,@body)) diff --git a/src/code/cl-specials.lisp b/src/code/cl-specials.lisp index a7274a99f..1e0972755 100644 --- a/src/code/cl-specials.lisp +++ b/src/code/cl-specials.lisp @@ -69,7 +69,8 @@ ;; extension/internal specials are also proclaimed early ;; to benefit from always-bound and precomputed TLS index. sb-kernel:*current-level-in-print* - sb-ext:*print-vector-length*))) + sb-ext:*print-vector-length* + sb-ext:*read-intern*))) `(progn (declaim (special ,@list) (sb-ext:always-bound ,@list)) @@ -142,7 +143,10 @@ cl:*query-io* cl:*terminal-io*)) -(declaim (type sb-kernel:function-designator cl:*debugger-hook* cl:*macroexpand-hook*)) +(declaim (type sb-kernel:function-designator + cl:*debugger-hook* + cl:*macroexpand-hook* + sb-ext:*read-intern*)) (declaim (type unsigned-byte cl:*gensym-counter*)) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 961112ef0..6d5e82341 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -141,6 +141,7 @@ (show-and-call !signal-function-cold-init) (show-and-call !printer-control-init) ; needed before first instance of FORMAT or WRITE-STRING (setq sb-unix::*unblock-deferrables-on-enabling-interrupts-p* nil) ; needed by LOAD-LAYOUT called by CLASSES-INIT + (setq sb-ext:*read-intern* nil) (setq *print-length* 6 *print-level* 3) (/show "testing '/SHOW" *print-length* *print-level*) ; show anything diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index cb1005c36..a0935327d 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1321,7 +1321,8 @@ NOTE: This interface is experimental and subject to change." (let ((*print-readably* nil) (*print-level* (or (true *print-level*) 6)) (*print-length* (or (true *print-length*) 12)) - #-sb-xc-host (*print-vector-length* (or (true *print-vector-length*) 200))) + #-sb-xc-host (*print-vector-length* (or (true *print-vector-length*) 200)) + #-sb-xc-host (*read-intern* nil)) (funcall function)))) ;;; Returns a list of members of LIST. Useful for dealing with circular lists. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index f26b49a62..e10d6392f 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1186,6 +1186,10 @@ standard Lisp readtable when NIL." (declaim (type (or null package) *reader-package*) (always-bound *reader-package*)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *read-intern* nil)) +(declaim (type sb-kernel:function-designator *read-intern*)) + (defun reader-find-package (package-designator stream restarts) (if (%instancep package-designator) package-designator @@ -1551,6 +1555,10 @@ extended <package-name>::<form-in-package> syntax." RETURN-SYMBOL (setf buf (normalize-read-buffer buf)) (casify-read-buffer buf) + (when (and *read-intern* (or (functionp *read-intern*) + (fboundp *read-intern*))) + (return (funcall *read-intern* + (sized-token-buf-string buf) package-designator))) (multiple-value-bind (pkg restart-kind) (if package-designator (reader-find-package package-designator stream t) diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index d0ee293f9..67feffc52 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -1061,6 +1061,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*.") "*DISASSEMBLE-ANNOTATE*" "PRINT-SYMBOL-WITH-PREFIX" "*PRINT-VECTOR-LENGTH*" + "*READ-INTERN*" "DECIMAL-WITH-GROUPED-DIGITS-WIDTH" ;;"OBJECT-SIZE"