X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=5d85c730bb09c8b51dd7a4f7c782961c78e242f9;hb=5762f26aae78beaead9919074963f67d92794599;hp=6ae6ce414e52f4ddad597a811baae4d951805a31;hpb=9cfc5c8e86d91ab491fb3d693ad28d972f3c1ac7;p=sbcl.git

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 6ae6ce4..5d85c73 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -250,17 +250,19 @@ standard Lisp readtable when NIL."
                           :test #'char= :key #'car)))
       (set-cat-entry to-char att to-readtable)
       (set-cmt-entry to-char mac to-readtable)
-      (when from-dpair
-        (cond
-          (to-dpair
-           (let ((table (cdr to-dpair)))
-             (clrhash table)
-             (shallow-replace/eql-hash-table table (cdr from-dpair))))
-          (t
-           (let ((pair (cons to-char (make-hash-table))))
-             (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+      (cond ((and (not from-dpair) (not to-dpair)))
+            ((and (not from-dpair) to-dpair)
              (setf (dispatch-tables to-readtable)
-                   (push pair (dispatch-tables to-readtable)))))))))
+                   (remove to-dpair (dispatch-tables to-readtable))))
+            (to-dpair
+             (let ((table (cdr to-dpair)))
+               (clrhash table)
+               (shallow-replace/eql-hash-table table (cdr from-dpair))))
+            (t
+             (let ((pair (cons to-char (make-hash-table))))
+               (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+               (setf (dispatch-tables to-readtable)
+                     (push pair (dispatch-tables to-readtable))))))))
   t)
 
 (defun set-macro-character (char function &optional
@@ -270,7 +272,8 @@ standard Lisp readtable when NIL."
   "Causes CHAR to be a macro character which invokes FUNCTION when seen
    by the reader. The NON-TERMINATINGP flag can be used to make the macro
    character non-terminating, i.e. embeddable in a symbol name."
-  (let ((designated-readtable (or rt-designator *standard-readtable*)))
+  (let ((designated-readtable (or rt-designator *standard-readtable*))
+        (function (%coerce-callable-to-fun function)))
     (assert-not-standard-readtable designated-readtable 'set-macro-character)
     (set-cat-entry char (if non-terminatingp
                             +char-attr-constituent+
@@ -901,9 +904,12 @@ standard Lisp readtable when NIL."
                (cond (all-lower (raise-em))
                      (all-upper (lower-em))))))))))))
 
+(defvar *reader-package* nil)
+
 (defun read-token (stream firstchar)
   #!+sb-doc
-  "This function is just an fsm that recognizes numbers and symbols."
+  "Default readmacro function. Handles numbers, symbols, and SBCL's
+extended <package-name>::<form-in-package> syntax."
   ;; Check explicitly whether FIRSTCHAR has an entry for
   ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
   ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
@@ -1257,9 +1263,12 @@ standard Lisp readtable when NIL."
       (case (char-class char attribute-array attribute-hash-table)
         (#.+char-attr-delimiter+
          (unread-char char stream)
-         (simple-reader-error stream
-                              "illegal terminating character after a colon: ~S"
-                              char))
+         (if package-designator
+             (let* ((*reader-package* (%find-package-or-lose package-designator)))
+               (return (read stream t nil t)))
+             (simple-reader-error stream
+                                  "illegal terminating character after a double-colon: ~S"
+                                  char)))
         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
         (#.+char-attr-package-delimiter+
@@ -1270,13 +1279,13 @@ standard Lisp readtable when NIL."
       RETURN-SYMBOL
       (casify-read-buffer escapes)
       (let ((found (if package-designator
-                       (find-package package-designator)
-                       (sane-package))))
-        (unless found
-          (error 'simple-reader-package-error :stream stream
-                 :format-arguments (list package-designator)
-                 :format-control "package ~S not found"))
-
+                       (or (find-package package-designator)
+                           (error 'simple-reader-package-error
+                                  :package package-designator
+                                  :stream stream
+                                  :format-control "Package ~A does not exist."
+                                  :format-arguments (list package-designator)))
+                       (or *reader-package* (sane-package)))))
         (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
             (return (intern* *read-buffer* *ouch-ptr* found))
             (multiple-value-bind (symbol test)
@@ -1284,7 +1293,9 @@ standard Lisp readtable when NIL."
               (when (eq test :external) (return symbol))
               (let ((name (read-buffer-to-string)))
                 (with-simple-restart (continue "Use symbol anyway.")
-                  (error 'simple-reader-package-error :stream stream
+                  (error 'simple-reader-package-error
+                         :package found
+                         :stream stream
                          :format-arguments (list name (package-name found))
                          :format-control
                          (if test