Commit bae85a50 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merge branch 'master' into xcvb

parents 7b6f978b d72ad1e7

.gitignore

0 → 100644
+2 −0
Changes for .gitignore: 2 added lines, 0 removed lines.
Original line number Diff line number Diff line 
*.fasl

*~

cruft.lisp

+23 −8
Changes for cruft.lisp: 23 added lines, 8 removed lines.
Original line number Diff line number Diff line
@@ -105,6 +105,21 @@ 
    (if (and (eq n1 :lambda) (eq n2 :lambda))

        (eq fn1 fn2)

        (equal n1 n2)))

  #+ :sbcl

  (let ((fn1 (ensure-function fn1))

        (fn2 (ensure-function fn2)))

    (or (eq fn1 fn2)

        ;; After SBCL 1.1.18, for dispatch macro characters

        ;; GET-MACRO-CHARACTER returns closures whose name is:

        ;;

        ;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR)

        ;; 

        ;; Treat all these closures equivalent.

        (let ((n1 (sb-impl::%fun-name fn1))

              (n2 (sb-impl::%fun-name fn2)))

          (and (listp n1) (listp n2)

               (find 'sb-impl::%make-dispatch-macro-char n1)

               (find 'sb-impl::%make-dispatch-macro-char n2)))))

  #+ :common-lisp

  (eq (ensure-function fn1) (ensure-function fn2)))
@@ -163,25 +178,25 @@ 
                     (let ((reader-fn (svref char-macro-array char-code))

                           (char (code-char (shiftf char-code (1+ char-code)))))

                       (if reader-fn

                           (yield char reader-fn)

                           (yield char)

                           (grovel-base-chars)))))

               (grovel-unicode-chars ()

                 (multiple-value-bind (more? char reader-fn) (ht-iterator)

                 (multiple-value-bind (more? char) (ht-iterator)

                   (if (not more?)

                       (values nil nil nil nil nil)

                       (yield char reader-fn))))

               (yield (char reader-fn)

                 (let ((disp-ht))

                       (yield char))))

               (yield (char)

                 (let ((disp-fn (get-macro-character char readtable))

                       (disp-ht))

                   (cond

                     ((setq disp-ht (cdr (assoc char dispatch-tables)))

                      (let* ((disp-fn (get-macro-character char readtable))

                             (sub-char-alist))

                      (let ((sub-char-alist))

                        (maphash (lambda (k v)

                                   (push (cons k v) sub-char-alist))

                                 disp-ht)

                        (values t char disp-fn t sub-char-alist)))

                     (t

                      (values t char reader-fn nil nil))))))

                      (values t char disp-fn nil nil))))))

        #'grovel-base-chars))))



#+clozure

named-readtables.lisp

+6 −5
Changes for named-readtables.lisp: 6 added lines, 5 removed lines.
Original line number Diff line number Diff line
@@ -343,14 +343,15 @@ guaranteed to be fresh, but may contain duplicates." 
             (to-readtable condition))))

  (:documentation "Continuable.



This condition is signaled during the merge process if a) a reader macro

\(be it a macro character or the sub character of a dispatch macro

character\) is both present in the source as well as the target readtable,

and b) if and only if the two respective reader macro functions differ."))

  This condition is signaled during the merge process if a reader

  macro (be it a macro character or the sub character of a dispatch

  macro character) is present in the both source and the target

  readtable and the two respective reader macro functions differ."))



(defun check-reader-macro-conflict (from to char &optional subchar)

  (flet ((conflictp (from-fn to-fn)

           (assert from-fn) ; if this fails, there's a bug in readtable iterators.

           (assert from-fn ()

                   "Bug in readtable iterators or concurrent access?")

           (and to-fn (not (function= to-fn from-fn)))))

    (when (if subchar

              (conflictp (%get-dispatch-macro-character char subchar from)

tests/tests.lisp

+33 −0
Changes for tests/tests.lisp: 33 added lines, 0 removed lines.
Original line number Diff line number Diff line
@@ -79,6 +79,14 @@ 
(defreadtable A-as-X

  (:macro-char #\A #'read-A-as-X))



(defreadtable A-dispatch

  (:macro-char #\A :dispatch)

  (:dispatch-macro-char #\A #\A #'read-A))



(defreadtable A-dispatch-as-X

  (:macro-char #\A :dispatch)

  (:dispatch-macro-char #\A #\A #'read-A-as-X))



(defreadtable B

  (:macro-char #\B #'read-B))
@@ -276,6 +284,31 @@ 
      (merge-readtables-into (make-readtable) :standard 'sharp-paren))

  t)



(deftest reader-macro-conflict.5

    (signals-condition-p 'reader-macro-conflict

      (merge-readtables-into (make-readtable) 'A 'A-dispatch))

  t)



(deftest reader-macro-conflict.6

    (signals-condition-p 'reader-macro-conflict

      (merge-readtables-into (make-readtable) 'A-dispatch 'A))

  t)



(deftest reader-macro-conflict.7

    (signals-condition-p 'reader-macro-conflict

      (merge-readtables-into (make-readtable) 'A-dispatch 'A-dispatch-as-X))

  t)



(deftest reader-macro-conflict.8

    (signals-condition-p 'reader-macro-conflict

      (merge-readtables-into (make-readtable) 'A 'A))

  nil)



(deftest reader-macro-conflict.9

    (signals-condition-p 'reader-macro-conflict

      (merge-readtables-into (make-readtable) 'A-dispatch 'A-dispatch))

  nil)





(deftest readtable-does-not-exist.1

    (signals-condition-p 'readtable-does-not-exist