diff options
| -rw-r--r-- | pkg.lisp | 287 |
1 files changed, 287 insertions, 0 deletions
diff --git a/pkg.lisp b/pkg.lisp new file mode 100644 index 0000000..0f12f40 --- /dev/null +++ b/pkg.lisp @@ -0,0 +1,287 @@ +;;; +;;; 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) +;;; | (top) +;;; | (directive-list) +;;; +;;; 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 inherits everything from the surrouding +;;; package as if via USE-PACKAGE. It uses no other 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. +;;; +;;; (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. +;;; +;;; 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 %packy-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 check-specifier (specifier) + (typecase specifier + ((or string symbol)) + (otherwise (error "#@: ~A does not name a symbol." specifier)))) + + (defun use-packages (specifiers) + (loop for specifier in specifiers + do (check-specifier specifier) + (let ((package (find-package specifier))) + (when (null package) + (error "#@: package ~A does not exist." specifier)) + (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)))) + (loop for specifier in specifiers + do (check-specifier specifier) + (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 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 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))) + + (defun dispatch-macro (stream sub-character integer-param) + (declare (ignore integer-param)) + (let* ((temp-package-name (gensym)) + (temp-package (make-package (gensym) :use nil)) + (*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* %packy-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)) |