Commit fee98763 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Various additions.

* The recent addition of empty readtables broke named-readtables
  fundamentally. Thanks for David Crawford for pointing that out.

  I had to accomodate MERGE-READTABLES-INTO now that the neutral
  element is no longer the standard readtable, but an empty
  readtable.

* We no make the readtable empty first when redefining it via a
  DEFREADTABLE form. Then the content is refilled.

* MERGE-READTABLES-INTO now signals a new error
  READER-MACRO-CONFLICT if a macro character is present
  in more than one of the argument readtables.

  DEFREADTABLE turns READER-MACRO-CONFLICT into a warning.

* Fix expansion of DEFREADTABLE so calls to MERGE-READTABLES-INTO
  properly quote readtable names.

* Add WITHOUT-PACKAGE-LOCK for our :AROUND method of PRINT-OBJECT
  specializing on READTABLE.

* Update docstrings accordingly.

darcs-hash:20090919175636-f5546-c5f68eb6d7fe114afee170aa225e95ea80e6291a.gz
parent 9c7fb975
...@@ -99,6 +99,44 @@ ...@@ -99,6 +99,44 @@
#+ :allegro (excl:named-readtable (readtable-name-for-allegro name)) #+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
#+ :common-lisp (values (gethash name *named-readtables* nil))) #+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Reader-macro related predicates
(define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?"
;; CCL has a bug that prevents the portable form below from
;; working. Patch has been sent upstream. (2009-09-19.)
#+ :ccl
(let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt)))))
(or (consp (cdr def))
(eq (car def) #'ccl::read-dispatch)))
#+ :common-lisp
(handler-case (prog1 t
(get-dispatch-macro-character char #\x rt))
(error () nil)))
;; (defun macro-char-p (char rt)
;; (let ((reader-fn (get-macro-character char rt)))
;; (and reader-fn
;; ;; Allegro stores READ-TOKEN as reader macro function of each
;; ;; constituent character.
;; #+allegro
;; (let ((read-token-fn
;; (load-time-value (get-macro-character #\A *standard-readtable*))))
;; (not (eq reader-fn read-token-fn))))))
;; (defun standard-macro-char-p (char rt)
;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
;; (and (eq rt-fn std-fn)
;; (eq rt-flag std-flag)))))
;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
;; (and (eq (non-terminating-p disp-char rt)
;; (non-terminating-p disp-char *standard-readtable*))
;; (eq (get-dispatch-macro-character disp-char sub-char rt)
;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
;;;; Readtables Iterators ;;;; Readtables Iterators
...@@ -193,12 +231,13 @@ ...@@ -193,12 +231,13 @@
#-(or sbcl clozure allegro) #-(or sbcl clozure allegro)
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
(let ((*print-pretty* t))
(simple-style-warn (simple-style-warn
"~A hasn't been ported to ~A. ~ "~@<~A hasn't been ported to ~A. ~
We fall back to a portable implementation of readtable iterators. ~ We fall back to a portable implementation of readtable iterators. ~
This implementation has to grovel through all available characters. ~ This implementation has to grovel through all available characters. ~
On Unicode-aware implementations this comes with some costs." On Unicode-aware implementations this comes with some costs.~@:>"
(package-name *package*) (lisp-implementation-type))) (package-name *package*) (lisp-implementation-type))))
#-(or sbcl clozure allegro) #-(or sbcl clozure allegro)
(defun %make-readtable-iterator (readtable) (defun %make-readtable-iterator (readtable)
...@@ -243,6 +282,19 @@ ...@@ -243,6 +282,19 @@
(unless ,more? (return ,result)) (unless ,more? (return ,result))
,@body)))))) ,@body))))))
;;;; Misc
(declaim (special *standard-readtable*))
(defun %clear-readtable (readtable)
"Make all macro characters in READTABLE be consituents."
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable *standard-readtable*))
;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;; readtable's dispatch table properly.
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable)
;;;; Specialized PRINT-OBJECT for named readtables. ;;;; Specialized PRINT-OBJECT for named readtables.
...@@ -259,5 +311,5 @@ ...@@ -259,5 +311,5 @@
(let ((name (readtable-name rt))) (let ((name (readtable-name rt)))
(if name (if name
(print-unreadable-object (rt stream :type nil :identity t) (print-unreadable-object (rt stream :type nil :identity t)
(format stream "~A ~S" (string :named-readtable) name)) (format stream "~A ~S" :named-readtable name))
(call-next-method))))) (call-next-method)))))
\ No newline at end of file
This diff is collapsed.
...@@ -19,8 +19,9 @@ ...@@ -19,8 +19,9 @@
;; Types ;; Types
#:named-readtable-designator #:named-readtable-designator
;; Conditions ;; Conditions
#:readtable-does-not-exist #:reader-macro-conflict
#:readtable-does-already-exist #:readtable-does-already-exist
#:readtable-does-not-exist
) )
(:documentation (:documentation
" "
...@@ -150,7 +151,7 @@ ...@@ -150,7 +151,7 @@
- NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/. - NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/.
- :MODERM designates a _case-preserving_ /standard-readtable/. - :MODERN designates a _case-preserving_ /standard-readtable/.
- :CURRENT designates the /current readtable/. - :CURRENT designates the /current readtable/.
...@@ -178,6 +179,8 @@ ...@@ -178,6 +179,8 @@
> ... > ...
> >
> (in-readtable scheme:syntax) > (in-readtable scheme:syntax)
>
> ...
* Acknowledgements * Acknowledgements
......
...@@ -16,6 +16,14 @@ ...@@ -16,6 +16,14 @@
:format-control format-control :format-control format-control
:format-arguments format-args)) :format-arguments format-args))
(defmacro without-package-lock ((&rest package-names) &body body)
(declare (ignorable package-names))
#+clisp (return-from without-package-lock
`(ext:without-package-lock (,@package-names) ,@body))
`(progn ,@body))
;;; Taken from SWANK (which is Public Domain.) ;;; Taken from SWANK (which is Public Domain.)
(defmacro destructure-case (value &rest patterns) (defmacro destructure-case (value &rest patterns)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment