Annotation 2 from http://paste.lisp.org/display/72068

Bugfixes, new directive.

1 files changed, 58 insertions, 26 deletions

diff --git a/pkg.lisp b/pkg.lisp
index c41a3d1..2d98af7 100644
--- a/pkg.lisp
+++ b/pkg.lisp
@@ -1,3 +1,10 @@
+; Previous versions were not importing NIL from surrounding package into
+; the anonymous package, because (IMPORT NIL ...) interprets NIL as an empty
+; list. This inheritance is now done via a more sophisticated package cloning
+; operation, which steals the present symbols, package use list and shadowing
+; list of the package. 
+; The useful directive IN is added.
+
 ;;;
 ;;; PKG---read time manipulation of package visibility.
 ;;;
@@ -45,6 +52,7 @@
 ;;;             |  (keep symbol-specifier-list)
 ;;;             |  (intern symbol-specifier-list)
 ;;;             |  (top)
+;;;             |  (in package-specifier) 
 ;;;             |  (directive-list)
 ;;;             |  ()
 ;;;             |  nil
@@ -75,8 +83,12 @@
 ;;; those of earlier directives.  
 ;;;
 ;;; Before the first directive is processed, an initial anonymous package is
-;;; established. This package inherits everything from the surrouding
-;;; package as if via USE-PACKAGE. It uses no other package.
+;;; established. This package is a clone of the surrounding package, meaning
+;;; that all symbols that are present in the surrounding package are 
+;;; made present in this anonymous package, all packages which
+;;; are used by the surrounding package are also used by the anonymous
+;;; package, and the anonymous package has an identical shadow symbol
+;;; list as the surrounding package.
 ;;;
 ;;; The actions of the directives are:
 ;;;
@@ -147,12 +159,10 @@
 ;;; (top)
 ;;;
 ;;;    This directive discards the anonymous package constructed
-;;;    so far and replaces it with a new one. Before replacing it with
-;;;    a new one, it severs the relationship with the surrounding package,
-;;;    and installs the toplevel package as the surrounding package.
-;;;    Then symbols are inherited from the surrounding package
-;;;    (which is now the toplevel package). When reconciliation is
-;;;    performed, it will be against the toplevel package.
+;;;    so far and replaces it with a new one. The new package is
+;;;    a clone of the toplevel package instead of the surrounding
+;;;    package. Moreover, when reconciliation is later preformed, it
+;;;    it will be against the toplevel package.
 ;;; 
 ;;;    The toplevel package is defined as the the *PACKAGE* that is
 ;;;    in effect when the reader is entered nonrecursively to scan a
@@ -171,6 +181,17 @@
 ;;;    and then an enclosing #@ may try to import symbosl having
 ;;;    the same names.
 ;;;
+;;; (in package-specifier)
+;;;
+;;;    This directive behaves exactly like top, except 
+;;;    with respect to the specified package instead of the
+;;;    toplevel package. The package must exist, or else error
+;;;    is signaled. The current anonymous package is discarded,
+;;;    and a new one is constructed which is a clone of the
+;;;    specified one. The specified package is now considered
+;;;    the surrounding package, and reconciliation will be
+;;;    done against it.
+;;;
 ;;; nil
 ;;; ()
 ;;;
@@ -251,19 +272,30 @@
   (defun specifiers-to-syms (specifiers)
     (mapcar #'specifier-to-sym specifiers))
 
+  (defun specifier-to-package (specifier)
+    (or (find-package (specifier-to-sym specifier))
+        (error "#@: package ~A does not exist." specifier)))
+
+  (defun copy-package (package)
+    (let ((new-package (make-package (gensym) :use ())))
+      (loop for sym being each present-symbol of package
+            do (import (or sym (list sym)) new-package))
+      (loop for sym in (package-shadowing-symbols package)
+            do (shadow (symbol-name sym) new-package))
+      (loop for pkg in (package-use-list package)
+            do (use-package pkg new-package))
+      new-package))
+
   (defun use-packages (specifiers)
-    (loop for package-name in (specifiers-to-syms specifiers)
-          do (let ((package (find-package package-name)))
-               (when (null package)
-                 (error "#@: package ~A does not exist." package-name))
+    (loop for package-name in specifiers
+          do (let ((package (specifier-to-package package-name)))
                (loop for sym being each external-symbol of package
                      do (if (find-symbol (symbol-name sym))
                           (shadowing-import sym))
                      finally (use-package package)))))
 
   (defun import-specified-syms (from-package specifiers &key no-error)
-    (let ((package (or (find-package from-package)
-                       (error "#@: package ~A does not exist." from-package))))
+    (let ((package (specifier-to-package from-package)))
       (loop for specifier in (specifiers-to-syms specifiers)
             do (let ((symbol (or (find-symbol (symbol-name specifier) package)
                                  (unless no-error
@@ -272,10 +304,6 @@
                  (if symbol
                    (shadowing-import symbol))))))
 
-  (defun import-all-symbols-from (from-package &optional (to-package *package*))
-    (loop for sym being each symbol of from-package
-          do (import sym to-package)))
-
   (defun intern-specified-syms (specifiers)
     (loop for specifier in (specifiers-to-syms specifiers)
           do (let ((sym (find-symbol (symbol-name specifier))))
@@ -293,13 +321,18 @@
          (mapc #'evaluate form)
          (let ((sym (first form)))
            (case sym
-             (top (setf (env-this-package *env*) (make-package (gensym) 
-                                                               :use nil)
-                        (env-previous-package *env*) (toplevel-package *env*)
+             (top (setf (env-previous-package *env*) (toplevel-package *env*)
+                        (env-this-package *env*) (copy-package 
+                                                   (env-previous-package *env*))
+                        (env-parent *env*) nil
+                        *package* (progn (delete-package *package*)
+                                         (env-this-package *env*))))
+             (in (let ((package (specifier-to-package (second form))))
+                   (setf (env-previous-package *env*) package
+                        (env-this-package *env*) (copy-package package)
                         (env-parent *env*) nil
                         *package* (progn (delete-package *package*)
-                                         (env-this-package *env*)))
-                  (import-all-symbols-from (toplevel-package *env*)))
+                                         package))))
              (inherit (setf (env-this-package *env*) (make-package (gensym) 
                                                                    :use nil)
                             *package* (progn (delete-package *package*)
@@ -322,13 +355,11 @@
 
   (defun dispatch-macro (stream sub-character integer-param)
     (declare (ignore integer-param))
-    (let* ((temp-package-name (gensym))
-           (temp-package (make-package (gensym) :use nil))
+    (let* ((temp-package (copy-package *package*))
            (*env* (make-env :parent *env* 
                             :this-package temp-package
                             :previous-package *package*))
            (*package* temp-package))
-      (import-all-symbols-from (env-previous-package *env*))
       (evaluate (let ((*package* %directive-package%))
                   (read stream t nil t)))
       (prog1 
@@ -338,3 +369,4 @@
                            (env-retain-syms *env*)))))
 
   (set-dispatch-macro-character #\# #\@ #'dispatch-macro))
+