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

New intern directive, empty directives, bugfixes.

1 files changed, 104 insertions, 51 deletions

diff --git a/pkg.lisp b/pkg.lisp
index 0f12f40..c41a3d1 100644
--- a/pkg.lisp
+++ b/pkg.lisp
@@ -43,8 +43,11 @@
 ;;;             |  (from package-specifier import symbol-specifier-list)
 ;;;             |  (inherit symbol-specifier-list)
 ;;;             |  (keep symbol-specifier-list)
+;;;             |  (intern symbol-specifier-list)
 ;;;             |  (top)
 ;;;             |  (directive-list)
+;;;             |  ()
+;;;             |  nil
 ;;;
 ;;;   directive-list  := ({directive}*)
 ;;;              
@@ -132,19 +135,54 @@
 ;;;    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)
+;;;
+;;;    Specifies symbols which are to be installed in the anonymous
+;;;    package as resident symbols. 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.
+;;;
 ;;; (top)
 ;;;
-;;;    This directive replaces the anonymous package with a new
-;;;    one which inherits symbols from the toplevel package, rather
-;;;    than the surrounding package. The toplevel package is
-;;;    the *PACKAGE* that is in effect when the reader is entered
-;;;    to scan a toplevel form. This may be diferent from the
-;;;    surrounding package, because #@ syntax instances may occur within
-;;;    forms that are already controlled by #@ syntax. The
-;;;    surrounding package for these nested instances is the
-;;;    anonymous package set up by the enclosing #@ syntax.
-;;;    The TOP directive is a way of gaining access to the outermost
-;;;    package.
+;;;    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.
+;;; 
+;;;    The toplevel package is defined as the the *PACKAGE* that is
+;;;    in effect when the reader is entered nonrecursively to scan a
+;;;    toplevel form. This may be diferent from what a #@ construct
+;;;    considers to be surrounding package, because #@ constructs may
+;;;    occur within forms that are already controlled by other #@
+;;;    syntax. The surrounding package for these nested instances is
+;;;    the anonymous package set up by the inner-most enclosing #@
+;;;    syntax.
+;;;
+;;;    Remark: the TOP directive is a way of gaining two-way access 
+;;;    to the outermost package.
+;;;    Remark: by bypassing the nesting of packages, TOP may cause 
+;;;    conflicts. That is to say, an inner #@ using TOP may import
+;;;    new symbols into the toplevel package during its reconciliation,
+;;;    and then an enclosing #@ may try to import symbosl having
+;;;    the same names.
+;;;
+;;; nil
+;;; ()
+;;;
+;;;    These are "noop" directives, which do nothing.
+;;;
+;;;    The syntax   #@() FORM  is equivalent to   FORM   except
+;;;    that if evaluation is invoked during the processing of FORM
+;;;    (e.g. via the sharpsign-dot reader) it will be able to
+;;;    observe that a temporary package is in effect, and that
+;;;    lexically earlier symbols have not yet been interned into 
+;;;    the surrounding package.
+;;;
 ;;;
 ;;; Reconciliation
 ;;;
@@ -176,7 +214,7 @@
 (in-package #:pkg)
 
 (eval-when (:compile-toplevel load-toplevel :execute)
-  (defconstant %packy-package% (find-package '#:pkg))
+  (defconstant %directive-package% (find-package '#:pkg))
   (defconstant %dispatch-char% #\@)
 
   (defvar *env* nil)
@@ -204,17 +242,20 @@
             (setf *package* above-package)
             (import syms above-package)))
 
-  (defun check-specifier (specifier)
+  (defun specifier-to-sym (specifier)
     (typecase specifier
-      ((or string symbol))
+      (string (intern specifier %directive-package%))
+      (symbol specifier)
       (otherwise (error "#@: ~A does not name a symbol." specifier))))
 
+  (defun specifiers-to-syms (specifiers)
+    (mapcar #'specifier-to-sym specifiers))
+
   (defun use-packages (specifiers)
-    (loop for specifier in specifiers
-          do (check-specifier specifier)
-             (let ((package (find-package specifier)))
+    (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." specifier))
+                 (error "#@: package ~A does not exist." package-name))
                (loop for sym being each external-symbol of package
                      do (if (find-symbol (symbol-name sym))
                           (shadowing-import sym))
@@ -223,9 +264,8 @@
   (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))))
-      (loop for specifier in specifiers
-            do (check-specifier specifier)
-               (let ((symbol (or (find-symbol (symbol-name specifier) 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)))))
@@ -236,36 +276,49 @@
     (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))))
+               (when sym
+                 (unintern sym))
+               (when (find-symbol (symbol-name specifier))
+                 (shadow specifier))
+               (intern (symbol-name specifier)))))
+
   (defun evaluate (form)
-    (if (consp form)
-      (if (consp (first form))
-        (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*)
-                       (env-parent *env*) nil
-                       *package* (progn (delete-package *package*)
-                                        (env-this-package *env*)))
-                 (import-all-symbols-from (toplevel-package *env*)))
-            (inherit (setf (env-this-package *env*) (make-package (gensym) 
-                                                                  :use nil)
-                           *package* (progn (delete-package *package*)
-                                            (env-this-package *env*)))
-                     (import-specified-syms (env-previous-package *env*)
-                                            (rest form)))
-            (keep (setf (env-retain-syms *env*) (rest form))
-                  (import-specified-syms (env-previous-package *env*)
-                                         (rest form)
-                                         :no-error t))
-            (use (use-packages (rest form)))
-            (from (destructuring-bind (from from-package import 
-                                            &rest specifiers) form
-                    (unless (and (eq import 'import))
-                      (error "#@: bad FROM package IMPORT syms syntax."))
-                    (import-specified-syms from-package specifiers)))
-            (otherwise (error "#@: ~A is an unknown directive." sym)))))
-      (error "#@: bad syntax: ~A" form)))
+    (cond
+      ((null form))
+      ((consp form)
+       (if (consp (first form))
+         (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*)
+                        (env-parent *env*) nil
+                        *package* (progn (delete-package *package*)
+                                         (env-this-package *env*)))
+                  (import-all-symbols-from (toplevel-package *env*)))
+             (inherit (setf (env-this-package *env*) (make-package (gensym) 
+                                                                   :use nil)
+                            *package* (progn (delete-package *package*)
+                                             (env-this-package *env*)))
+                      (import-specified-syms (env-previous-package *env*)
+                                             (rest form)))
+             (keep (setf (env-retain-syms *env*) (rest form))
+                   (import-specified-syms (env-previous-package *env*)
+                                          (rest form)
+                                          :no-error t))
+             (intern (intern-specified-syms (rest form)))
+             (use (use-packages (rest form)))
+             (from (destructuring-bind (from from-package import 
+                                             &rest specifiers) form
+                     (unless (and (eq import 'import))
+                       (error "#@: bad FROM package IMPORT syms syntax."))
+                     (import-specified-syms from-package specifiers)))
+             (otherwise (error "#@: ~A is an unknown directive." sym))))))
+      (t (error "#@: bad syntax: ~A" form))))
 
   (defun dispatch-macro (stream sub-character integer-param)
     (declare (ignore integer-param))
@@ -276,7 +329,7 @@
                             :previous-package *package*))
            (*package* temp-package))
       (import-all-symbols-from (env-previous-package *env*))
-      (evaluate (let ((*package* %packy-package%))
+      (evaluate (let ((*package* %directive-package%))
                   (read stream t nil t)))
       (prog1 
         (read stream t nil t)