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

Syntax and semantic changes.
[Note: contains the fix promised in Annotation 3.]

1 files changed, 109 insertions, 49 deletions

diff --git a/pkg.lisp b/pkg.lisp
index 997939f..39e34fb 100644
--- a/pkg.lisp
+++ b/pkg.lisp
@@ -1,3 +1,14 @@
+;
+; Changes:
+;
+; - Default behavior is not to keep any symbols. The KEEP-ALL directive
+;   has been introduced for requesting the old default behavior.
+; - The anonymous package is not deleted. This would be hostile to
+;   debugging code in which local variables and such are homeless syms.
+; - The INTERN directive is renamed UNIQUE. It has a new behavior:
+;   symbols created by it are not propagated to the surrounding
+;   package, even if they are on the KEEP list.
+
 ;;;
 ;;; PKG---read time manipulation of package visibility.
 ;;;
@@ -33,7 +44,6 @@
 ;;; The form is then read under that package. After the form is read,
 ;;; the anonymous package is reconciled against the surrounding package;
 ;;; which may involve pushing symbols into the surrounding package.
-;;; The anonymous package is then deleted.
 ;;;
 ;;; Syntax:
 ;;;
@@ -43,7 +53,8 @@
 ;;;             |  (from package-specifier import symbol-specifier-list)
 ;;;             |  (inherit symbol-specifier-list)
 ;;;             |  (keep symbol-specifier-list)
-;;;             |  (intern symbol-specifier-list)
+;;;             |  (keep-all)
+;;;             |  (unique symbol-specifier-list)
 ;;;             |  (top)
 ;;;             |  (in package-specifier) 
 ;;;             |  (directive-list)
@@ -75,12 +86,16 @@
 ;;; to right. The effects of later directives may override
 ;;; those of earlier directives.  
 ;;;
+;;; Over the processing of the directives and the form, the *package*
+;;; variable is dynamically rebound, so that its prior value is
+;;; saved and restored.
+;;;
 ;;; Before the first directive is processed, an initial anonymous package is
-;;; 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
+;;; created and stored in *package*. 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:
@@ -121,7 +136,8 @@
 ;;;
 ;;; (keep symbol-specifier-list)
 ;;;
-;;;    Constraint: only one KEEP directive should be specified.
+;;;    Constraint: at most one KEEP directive should be specified, and should
+;;;    be regarded as mutually exclusive with KEEP-ALL.
 ;;;
 ;;;    First, the specified symbols, if any, are are looked up in the
 ;;;    surrounding package. If any of them are visible there, they are
@@ -130,25 +146,53 @@
 ;;;    Second, the list of symbol specifiers is remembered.
 ;;;    When, at the end of processing, the anonymous package is
 ;;;    reconciled against the surrounding package, this list specifies
-;;;    precisely which symbols present in the anonymous package
-;;;    are to be imported into the surrounding package.
+;;;    which symbols present in the anonymous package
+;;;    are to be considered for propagation into the surrounding package.
 ;;;
-;;;    The default behavior, if a KEEP directive is not specified,
-;;;    is that all present symbols in the anonymous package are propagated.
+;;;    The default behavior, neither the KEEP nor KEEP-ALL directives
+;;;    are used is that none of the symbols interned in the anonymous
+;;;    package are propagated, which is equivalent to (KEEP).
 ;;;
 ;;;    The KEEP directive's remembered list stays in effect regardless
 ;;;    of the directives that follow. Directives which scrap the
 ;;;    anonymous package for a new one do not affect the keep list.
 ;;;
-;;; (intern symbol-specifier-list)
+;;; (keep-all)
+;;;
+;;;    Constraint: at most one KEEP-ALL directive should be specified,
+;;;    and should be regarded as mutually exclusive with KEEP.
+;;;
+;;;    First, KEEP-ALL ensures that all symbols present in the
+;;;    surrounding package are made present in the anonymous package,
+;;;    and any remaining that are visible in that package are
+;;;    made visibel in the anonymous package also.
+;;;
+;;;    Second, it is rememberd that KEEP-ALL was specified, so
+;;;    that when at the end of processing when the anonymous
+;;;    package is reconciled with the surrounding package,
+;;;    all new symbols present in the anonymous package are
+;;;    to be considered for propagation.
+;;;
+;;; (unique symbol-specifier-list)
 ;;;
-;;;    Specifies symbols which are to be installed in the anonymous
-;;;    package as resident symbols. If symbols of the same name
+;;;    The specified symbols are newly created, and installed in the
+;;;    anonymous package. If symbols of the same name
 ;;;    are already present, those symbols are uninterned first.
 ;;;    If symbols of the same name are visible in the package
 ;;;    by use inheritance, then they are added to the shadow list.
 ;;;    to resolve the conflict.
 ;;;
+;;;    The symbols are added to a suppress list, which is empty
+;;;    at the start of processing, and is considered during
+;;;    reconciliation.
+;;;
+;;;    Symbols on the suppress list will not be propagated
+;;;    to the surrounding package even if they are on the keep list.
+;;;
+;;;    Directives which scrap the anonymous package in favor
+;;;    of a new one also clear the suppress list, since
+;;;    the symbols on that list are no longer pertinent.
+;;;
 ;;; (top)
 ;;;
 ;;;    This directive discards the anonymous package constructed
@@ -207,19 +251,21 @@
 ;;; 1. All symbols which are present in the anonymous package, and whose
 ;;;    home package is that package (i.e. all symbols that were newly interned
 ;;;    in that anonymous package when FORM was read) are gathered into
-;;;    a list. If a keep list was established by a (KEEP) directive,
+;;;    a list. 
+;;;
+;;; 2. If a KEEP-ALL directive was specified then all of these
+;;;    symbols are eligible or propagation into the surrounding package.
+;;;    If a specific keep list was established by a (KEEP) directive,
 ;;;    then symbols which are not in that list are removed from further
 ;;;    consideration.
 ;;;
-;;; 2. The sourrounding package is installed as the current
-;;;    package in the *PACKAGE* variable.
-;;;
-;;; 3. The anonymous package is deleted by DELETE-PACKAGE, rendering
-;;;    the symbols in the list homeless.
+;;; 3. If a suppress list was established by one or more UNIQUE
+;;;    directives, then all of the symbols being considered which
+;;;    are on that list are removed from further consideration.
 ;;;
-;;; 4. The symbols in the list are propagated into the surrounding package
-;;;    by a an import (a non-shadowing import, which may cause conflicts to be
-;;;    signaled).
+;;; 2. The symbols remaining the list are propagated into the surrounding 
+;;;    package by a an import (a non-shadowing import, which may cause
+;;;    conflicts to be signaled).
 ;;;
 
 (defpackage #:pkg
@@ -237,7 +283,8 @@
     (parent)
     (this-package)
     (previous-package)
-    (retain-syms t)
+    (retain-syms)
+    (suppress-syms)
     (stash))
 
   (defun toplevel-package (env)
@@ -245,16 +292,16 @@
       (toplevel-package (env-parent env))
       (env-previous-package env)))
 
-  (defun reconcile-package (here-package above-package retain-syms)
+  (defun reconcile-package (here-package above-package 
+                            retain-syms suppress-syms)
     (loop for sym being each present-symbol of here-package
           when (and (eq (symbol-package sym) here-package)
                     (or (eq retain-syms t)
                         (member sym retain-syms :test #'string=)))
-          collect sym into syms
+            collect sym into syms
           finally 
-            (delete-package here-package)
-            (setf *package* above-package)
-            (import syms above-package)))
+            (import (set-difference syms suppress-syms)
+                    above-package)))
 
   (defun specifier-to-sym (specifier)
     (typecase specifier
@@ -266,17 +313,21 @@
     (mapcar #'specifier-to-sym specifiers))
 
   (defun specifier-to-package (specifier)
-    (or (find-package (specifier-to-sym specifier))
+    (or (and (packagep specifier) specifier) 
+        (find-package (specifier-to-sym specifier))
         (error "#@: package ~A does not exist." specifier)))
 
+  (defun copy-visibility (from-package &optional (to-package *package*))
+    (loop for sym being each present-symbol of from-package
+          do (import (or sym (list sym)) to-package))
+    (loop for sym in (package-shadowing-symbols from-package)
+          do (shadow (symbol-name sym) to-package))
+    (loop for pkg in (package-use-list from-package)
+          do (use-package pkg to-package)))
+
   (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))
+      (copy-visibility package new-package)
       new-package))
 
   (defun use-packages (specifiers)
@@ -290,21 +341,22 @@
   (defun import-specified-syms (from-package specifiers &key no-error)
     (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
-                                   (error "#@: no symbol ~A in package ~A."
-                                          specifier from-package)))))
+            do (let ((symbol 
+                       (or (find-symbol (symbol-name specifier) package)
+                           (unless no-error
+                             (error "#@: no symbol ~A in package ~A."
+                                    specifier (package-name package))))))
                  (if symbol
                    (shadowing-import symbol))))))
 
   (defun intern-specified-syms (specifiers)
     (loop for specifier in (specifiers-to-syms specifiers)
-          do (let ((sym (find-symbol (symbol-name specifier))))
-               (when sym
-                 (unintern sym))
-               (when (find-symbol (symbol-name specifier))
-                 (shadow specifier))
-               (intern (symbol-name specifier)))))
+          collect (let ((sym (find-symbol (symbol-name specifier))))
+                    (when sym
+                      (unintern sym))
+                    (when (find-symbol (symbol-name specifier))
+                      (shadow specifier))
+                    (intern (symbol-name specifier)))))
 
   (defun evaluate (form)
     (cond
@@ -319,16 +371,19 @@
                                                    (env-previous-package *env*))
                         (env-parent *env*) nil
                         *package* (progn (delete-package *package*)
+                                         (setf (env-suppress-syms *env*) nil)
                                          (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*)
+                                         (setf (env-suppress-syms *env*) nil)
                                          package))))
              (inherit (setf (env-this-package *env*) (make-package (gensym) 
                                                                    :use nil)
                             *package* (progn (delete-package *package*)
+                                             (setf (env-suppress-syms *env*) nil)
                                              (env-this-package *env*)))
                       (import-specified-syms (env-previous-package *env*)
                                              (rest form)))
@@ -336,7 +391,11 @@
                    (import-specified-syms (env-previous-package *env*)
                                           (rest form)
                                           :no-error t))
-             (intern (intern-specified-syms (rest form)))
+             (keep-all (setf (env-retain-syms *env*) t)
+                       (copy-visibility (env-previous-package *env*)))
+             (unique (let ((newsyms (intern-specified-syms (rest form))))
+                       (setf (env-suppress-syms *env*)
+                             (union (env-suppress-syms *env*) newsyms))))
              (use (use-packages (rest form)))
              (from (destructuring-bind (from from-package import 
                                              &rest specifiers) form
@@ -359,6 +418,7 @@
         (read stream t nil t)
         (reconcile-package (env-this-package *env*) 
                            (env-previous-package *env*)
-                           (env-retain-syms *env*)))))
+                           (env-retain-syms *env*)
+                           (env-suppress-syms *env*)))))
 
   (set-dispatch-macro-character #\# #\@ #'dispatch-macro))