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

Various stuff:

  * DEFREADTABLE does _not_ have compile-toplevel effects anymore.

    This means you cannot use a readtable defined via DEFREADTABLE
    in the same file it's defined. Use an explicit EVAL-WHEN if you
    want to achieve that.

    Advantage: It's not necessary anymore to wrap reader-macro function
    definitions in EVAL-WHEN.

  * Add restartable conditions READTABLE-DOES-NOT-EXIST, and
    READTABLE-DOES-ALREADY-EXIST.

darcs-hash:20090828194425-f5546-479aa7c7378ff50f6dfe2cb390f105de7a279712.gz
parent 752ebd9e
...@@ -28,8 +28,6 @@ ...@@ -28,8 +28,6 @@
;;; ;;;
;;; * Add :FUZE that's like :MERGE without the style-warnings ;;; * Add :FUZE that's like :MERGE without the style-warnings
;;; ;;;
;;; * Revamp cruft.lisp, introduce DEFINTERFACE, DEFIMPLEMENTATION
;;;
;;; * Think about MAKE-DISPATCHING-MACRO-CHARACTER in DEFREADTABLE ;;; * Think about MAKE-DISPATCHING-MACRO-CHARACTER in DEFREADTABLE
...@@ -99,32 +97,37 @@ they appear." ...@@ -99,32 +97,37 @@ they appear."
((not (null other-clauses)) ((not (null other-clauses))
(error "Bogus DEFREADTABLE clauses: ~{~A~^, ~}" other-clauses)) (error "Bogus DEFREADTABLE clauses: ~{~A~^, ~}" other-clauses))
(t (t
`(eval-when (:compile-toplevel :load-toplevel :execute) `(eval-when (:load-toplevel :execute)
;; The (FIND-READTABLE ...) is important for proper redefinition semantics. ;; The (FIND-READTABLE ...) is important for proper redefinition semantics.
(let ((readtable (find-readtable ',name))) (handler-bind ((readtable-does-already-exist
(if readtable #'(lambda (c)
(simple-style-warn "redefining ~A in DEFREADTABLE" ',name) (simple-style-warn
(setq readtable "Overwriting previously existing readtable ~S."
(make-readtable ',name (existing-readtable-name c))
;; We have to provide an explicit :MERGE argument, (continue c))))
;; because otherwise the :STANDARD readtable would (let ((readtable (find-readtable ',name)))
;; be used which is not necessarily what we want. (setq readtable
:merge ',(rest (first merge-clauses))))) (make-readtable ',name
;; We have to grovel all MERGE-CLAUSES for the redefinition case. ;; We have to provide an explicit :MERGE argument,
,@(loop for option in merge-clauses ;; because otherwise the :STANDARD readtable would
collect (process-option option 'readtable)) ;; be used which is not necessarily what we want.
,@(loop for option in case-clauses :merge ',(rest (first merge-clauses))))
collect (process-option option 'readtable)) ;; We have to grovel all MERGE-CLAUSES for the redefinition case.
,@(loop for option in macro-clauses ,@(loop for option in merge-clauses
collect (process-option option 'readtable)) collect (process-option option 'readtable))
readtable))))))) ,@(loop for option in case-clauses
collect (process-option option 'readtable))
,@(loop for option in macro-clauses
collect (process-option option 'readtable))
readtable))))))))
;;; KLUDGE: ;;; KLUDGE:
;;; We need support for this in Slime itself, because we want IN-READTABLE ;;; We need support for this in Slime itself, because we want IN-READTABLE
;;; to work on a per-file basis, and not on a per-package basis. ;;; to work on a per-file basis, and not on a per-package basis.
;;; ;;;
(defun %frob-swank-readtable-alist (package readtable) (defun %frob-swank-readtable-alist (package readtable)
(let ((readtable-alist (find-symbol "*READTABLE-ALIST*" (find-package "SWANK")))) (let ((readtable-alist (find-symbol (string '#:*readtable-alist*)
(find-package :swank))))
(when (boundp readtable-alist) (when (boundp readtable-alist)
(pushnew (cons (package-name package) readtable) (pushnew (cons (package-name package) readtable)
(symbol-value readtable-alist) (symbol-value readtable-alist)
...@@ -140,7 +143,7 @@ an error if no such readtable can be found." ...@@ -140,7 +143,7 @@ an error if no such readtable can be found."
(check-type name symbol) (check-type name symbol)
`(eval-when (:compile-toplevel :load-toplevel :execute) `(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (ensure-readtable ',name)) (setf *readtable* (ensure-readtable ',name))
(when (find-package "SWANK") (when (find-package :swank)
(%frob-swank-readtable-alist *package* *readtable*)) (%frob-swank-readtable-alist *package* *readtable*))
)) ))
...@@ -155,9 +158,9 @@ the :STANDARD readtable is used instead." ...@@ -155,9 +158,9 @@ the :STANDARD readtable is used instead."
(cond ((reserved-readtable-name-p name) (cond ((reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~ (error "~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name." name)) Not acceptable as a user-specified readtable name." name))
((and (find-readtable name) ((let ((rt (find-readtable name)))
(cerror "Overwrite existing readtable." (and rt (cerror "Overwrite existing readtable."
"A readtable named ~S already exists." name))) 'readtable-does-already-exist :readtable rt))))
(t (let ((result (apply #'merge-readtables-into (t (let ((result (apply #'merge-readtables-into
;; The first readtable specified in the :merge list is ;; The first readtable specified in the :merge list is
;; taken as the basis for all subsequent (destructive!) ;; taken as the basis for all subsequent (destructive!)
...@@ -220,6 +223,23 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -220,6 +223,23 @@ guaranteed to be fresh, but may contain duplicates."
(deftype named-readtable-designator () (deftype named-readtable-designator ()
`(or readtable-designator symbol)) `(or readtable-designator symbol))
(define-condition readtable-error (error) ())
(define-condition readtable-does-not-exist (readtable-error)
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor missing-readtable-name)))
(define-condition readtable-does-already-exist (readtable-error)
((readtable-name :initarg :readtable
:initform (required-argument)
:accessor existing-readtable-name))
(:report (lambda (condition stream)
(format stream "A readtable named ~S already exists."
(existing-readtable-name condition)))))
;;; Although there is no way to get at the standard readtable in ;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make ;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
;;; up the perception of its existence by interning a copy of it. ;;; up the perception of its existence by interning a copy of it.
......
(in-package "COMMON-LISP-USER") (in-package :common-lisp-user)
(defpackage :editor-hints.named-readtables (defpackage :editor-hints.named-readtables
(:use :common-lisp) (:use :common-lisp)
...@@ -15,5 +15,9 @@ ...@@ -15,5 +15,9 @@
#:register-readtable #:register-readtable
#:unregister-readtable #:unregister-readtable
#:list-all-named-readtables #:list-all-named-readtables
;; Types
#:named-readtable-designator #:named-readtable-designator
;; Conditions
#:readtable-does-not-exist
#:readtable-does-already-exist
)) ))
\ No newline at end of file
...@@ -41,4 +41,12 @@ corresponding values in the CDR of VALUE." ...@@ -41,4 +41,12 @@ corresponding values in the CDR of VALUE."
,@body))))) ,@body)))))
,@(if (eq (caar (last patterns)) t) ,@(if (eq (caar (last patterns)) t)
'() '()
`((t (error "destructure-case failed: ~S" ,tmp)))))))) `((t (error "destructure-case failed: ~S" ,tmp))))))))
\ No newline at end of file
;;; Taken from Alexandria (which is Public Domain, or BSD.)
(defun required-argument (&optional name)
"Signals an error for a missing argument of NAME. Intended for
use as an initialization form for structure and class-slots, and
a default value for required keyword arguments."
(error "Required argument ~@[~S ~]missing." name))
\ No newline at end of file
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