path: root/pkg.lisp

; 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.
;;;
;;; Kaz Kylheku <kkylheku@gmail.com>
;;; December 2008
;;;
;;; Concept: 
;;;
;;; Common Lisp gives us a very coarse-grained instrument for
;;; controlling how symbols are interned. When the reader is entered
;;; to scan a form, there is some package in effect, stored in the
;;; dynamic variable *PACKAGE*. This package controls how unqualified
;;; symbol names are interpreted. Names are looked up through the package,
;;; and either resolve to symbols that are present in the package,
;;; visible through the package via use inheritance, or are not found.
;;; Names which are not found are interned as new symbols in the package.
;;; During the scanning of an entire form, the same *PACKAGE* is in
;;; effect, (unless some read-time manipulation via the sharpsign-dot
;;; read macro is performed).
;;; 
;;; What if we want more fine-grained control over how names are interpreted
;;; inside a form? Suppose that deeply inside some nested compound form,
;;; we would like some sub-form to have its symbols treated through
;;; a specific package. Or what if we would like to suppress the behavior of
;;; being automatically interned into the surrounding package?
;;;
;;; It's possible to achieve this by giving semantics to an extensible
;;; read-time notation. I have chosen to implement this as a #@ read
;;; macro (sharpsign-at). The #@ read macro reads the following form as
;;; a directive or list of directives. Then it reads another form, which
;;; is returned as a result of the scan. The directives establish an 
;;; anonymous package and customize the contents of that package.
;;; 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:
;;;
;;;   sharpsign-at := #@ directive form
;;;
;;;   directive := (use package-specifier-list)
;;;             |  (from package-specifier import symbol-specifier-list)
;;;             |  (inherit symbol-specifier-list)
;;;             |  (keep symbol-specifier-list)
;;;             |  (intern symbol-specifier-list)
;;;             |  (top)
;;;             |  (in package-specifier) 
;;;             |  (directive-list)
;;;             |  ()
;;;             |  nil
;;;
;;;   directive-list  := ({directive}*)
;;;              
;;;   package-specifier-list := {package-specifier}*
;;;
;;;   symbol-specifier-list := {symbol-specifier}*
;;;
;;;   package-specifier := symbol-specifier
;;;
;;;   symbol-specifier := string-literal | symbol
;;;
;;; Note: symbol specifiers are treated using name equivalence.
;;; The specifier FOO, #:FOO and "FOO" are the same specifier,
;;; (assuming the usual treatment of letter case in symbol names).
;;; FOO is interned in a private package internal to the #@ reader
;;; implementation, and does not pollute any existing package.
;;; This simple use is encouraged.
;;;
;;; Semantics
;;;
;;; General notes
;;;
;;; When multiple directives appear, they are processed left
;;; to right. The effects of later directives may override
;;; those of earlier directives.  
;;;
;;; 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
;;; list as the surrounding package.
;;;
;;; The actions of the directives are:
;;;
;;; (use package-specifier-list)
;;;
;;;    This directive means to make visible all of the exported
;;;    symbols in the specified packages. If any of the packages
;;;    do not exist, an error is signaled.
;;;
;;;    The packages are processed in left-to-right order,
;;;    and made visible in the anonymous package. Whenever
;;;    such a visibility would create a conflict, the
;;;    conflict is resolved in favor of the package via a shadowing
;;;    import.
;;;
;;; (from package-specifier import symbol-specifier-list)
;;;
;;;    Symbols from the specified package (which must exist, or
;;;    else an error is signaled) are made present in the
;;;    anonymous package by importing. Conflicts are automatically resolved ;;;
;;;    in favor of these symbols via shadowing imports.
;;;
;;; (inherit symbol-specifier-list)
;;;
;;;    The anonymous package is erased, and replaced with a new
;;;    empty anonymous package. Nothing is inherited or imported
;;;    into this anonymous package execpt for the symbols specified
;;;    by the list. If there are no symbols, the package is completely
;;;    empty, with no symbols present or visible in it.
;;;
;;;    Symbols specified in the list must all be visible in the surrounding
;;;    package, or else an error is signaled.
;;;
;;;    Remark: This form is most useful when it appears first, since it
;;;    clobbers the effects of earlier directives by replacing
;;;    the anonymous package.
;;;
;;; (keep symbol-specifier-list)
;;;
;;;    Constraint: only one KEEP directive should be specified.
;;;
;;;    First, the specified symbols, if any, are are looked up in the
;;;    surrounding package. If any of them are visible there, they are
;;;    imported into the anonymous package.
;;;
;;;    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.
;;;
;;;    The default behavior, if a KEEP directive is not specified,
;;;    is that all present symbols in the anonymous package are propagated.
;;;
;;;    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)
;;;
;;;    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 discards the anonymous package constructed
;;;    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
;;;    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.
;;;
;;; (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
;;; ()
;;;
;;;    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
;;;
;;; After the directives are processed, the FORM is read. Then, before
;;; the form is returned, package reconciliation takes place. 
;;; This is done as if by the following steps:
;;;
;;; 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,
;;;    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.
;;;
;;; 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).
;;;

(defpackage #:pkg
  (:use :cl))

(in-package #:pkg)

(eval-when (:compile-toplevel load-toplevel :execute)
  (defconstant %directive-package% (find-package '#:pkg))
  (defconstant %dispatch-char% #\@)

  (defvar *env* nil)

  (defstruct env
    (parent)
    (this-package)
    (previous-package)
    (retain-syms t)
    (stash))

  (defun toplevel-package (env)
    (if (env-parent env)
      (toplevel-package (env-parent env))
      (env-previous-package env)))

  (defun reconcile-package (here-package above-package retain-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
          finally 
            (delete-package here-package)
            (setf *package* above-package)
            (import syms above-package)))

  (defun specifier-to-sym (specifier)
    (typecase specifier
      (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 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
          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 (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)))))
                 (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)))))

  (defun evaluate (form)
    (cond
      ((null form))
      ((consp form)
       (if (consp (first form))
         (mapc #'evaluate form)
         (let ((sym (first form)))
           (case sym
             (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*)
                                         package))))
             (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))
    (let* ((temp-package (copy-package *package*))
           (*env* (make-env :parent *env* 
                            :this-package temp-package
                            :previous-package *package*))
           (*package* temp-package))
      (evaluate (let ((*package* %directive-package%))
                  (read stream t nil t)))
      (prog1 
        (read stream t nil t)
        (reconcile-package (env-this-package *env*) 
                           (env-previous-package *env*)
                           (env-retain-syms *env*)))))

  (set-dispatch-macro-character #\# #\@ #'dispatch-macro))