[armedbear-cvs] r14405 - in trunk/abcl: doc/manual src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Fri Mar 1 11:26:31 UTC 2013
Author: rschlatte
Date: Fri Mar 1 03:26:24 2013
New Revision: 14405
Log:
Support package-local nicknames
- Same API as SBCL (see manual)
- fasl version increased because arglist of %defpackage changed
Modified:
trunk/abcl/doc/manual/abcl.tex
trunk/abcl/doc/manual/abcl.texi
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Load.java
trunk/abcl/src/org/armedbear/lisp/Package.java
trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java
trunk/abcl/src/org/armedbear/lisp/Packages.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/Stream.java
trunk/abcl/src/org/armedbear/lisp/defpackage.lisp
Modified: trunk/abcl/doc/manual/abcl.tex
==============================================================================
--- trunk/abcl/doc/manual/abcl.tex Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/doc/manual/abcl.tex Fri Mar 1 03:26:24 2013 (r14405)
@@ -956,6 +956,105 @@
\end{itemize}
+\section{Package-Local Nicknames}
+\label{sec:pack-local-nickn}
+
+ABCL allows giving packages local nicknames: they allow short and
+easy-to-use names to be used without fear of name conflict associated
+with normal nicknames.\footnote{Package-local nicknames were originally
+developed in SBCL.}
+
+A local nickname is valid only when inside the package for which it
+has been specified. Different packages can use same local nickname for
+different global names, or different local nickname for same global
+name.
+
+Symbol \code{:package-local-nicknames} in \code{*features*} denotes the
+support for this feature.
+
+\index{DEFPACKAGE}
+The options to \code{defpackage} are extended with a new option
+\code{:local-nicknames (local-nickname actual-package-name)*}.
+
+The new package has the specified local nicknames for the corresponding
+actual packages.
+
+Example:
+\begin{listing-lisp}
+(defpackage :bar (:intern "X"))
+(defpackage :foo (:intern "X"))
+(defpackage :quux (:use :cl)
+ (:local-nicknames (:bar :foo) (:foo :bar)))
+(find-symbol "X" :foo) ; => FOO::X
+(find-symbol "X" :bar) ; => BAR::X
+(let ((*package* (find-package :quux)))
+ (find-symbol "X" :foo)) ; => BAR::X
+(let ((*package* (find-package :quux)))
+ (find-symbol "X" :bar)) ; => FOO::X
+\end{listing-lisp}
+
+\index{PACKAGE-LOCAL-NICKNAMES}
+--- Function: \textbf{package-local-nicknames} [\textbf{ext}] \textit{package-designator}
+
+\begin{adjustwidth}{5em}{5em}
+ Returns an alist of \code{(local-nickname . actual-package)}
+ describing the nicknames local to the designated package.
+
+ When in the designated package, calls to \code{find-package} with any
+ of the local-nicknames will return the corresponding actual-package
+ instead. This also affects all implied calls to \code{find-package},
+ including those performed by the reader.
+
+ When printing a package prefix for a symbol with a package local
+ nickname, the local nickname is used instead of the real name in order
+ to preserve print-read consistency.
+\end{adjustwidth}
+
+\index{PACKAGE-LOCALLY-NICKNAMED-BY-LIST}
+--- Function: \textbf{package-locally-nicknamed-by-list} [\textbf{ext}] \textit{package-designator}
+
+\begin{adjustwidth}{5em}{5em}
+Returns a list of packages which have a local nickname for the
+designated package.
+\end{adjustwidth}
+
+\index{ADD-PACKAGE-LOCAL-NICKNAME}
+--- Function: \textbf{add-package-local-nickname} [\textbf{ext}] \textit{local-nickname actual-package \&optional package-designator}
+
+\begin{adjustwidth}{5em}{5em}
+ Adds \code{local-nickname} for \code{actual-package} in the designated
+ package, defaulting to current package. \code{local-nickname} must be
+ a string designator, and \code{actual-package} must be a package
+ designator.
+
+ Returns the designated package.
+
+ Signals an error if \code{local-nickname} is already a package local
+ nickname for a different package, or if \code{local-nickname} is one
+ of "CL", "COMMON-LISP", or, "KEYWORD", or if \code{local-nickname} is
+ a global name or nickname for the package to which the nickname would
+ be added.
+
+ When in the designated package, calls to \code{find-package} with the
+ \code{local-nickname} will return the package the designated
+ \code{actual-package} instead. This also affects all implied calls to
+ \code{find-package}, including those performed by the reader.
+
+ When printing a package prefix for a symbol with a package local
+ nickname, local nickname is used instead of the real name in order to
+ preserve print-read consistency.
+\end{adjustwidth}
+
+\index{REMOVE-PACKAGE-LOCAL-NICKNAME}
+--- Function: \textbf{remove-package-local-nickname} [\textbf{ext}] \textit{old-nickname \&optional package-designator}
+
+\begin{adjustwidth}{5em}{5em}
+ If the designated package had \code{old-nickname} as a local nickname
+ for another package, it is removed. Returns true if the nickname
+ existed and was removed, and \code{nil} otherwise.
+\end{adjustwidth}
+
+
\section{Extensible Sequences}
Modified: trunk/abcl/doc/manual/abcl.texi
==============================================================================
--- trunk/abcl/doc/manual/abcl.texi Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/doc/manual/abcl.texi Fri Mar 1 03:26:24 2013 (r14405)
@@ -1319,6 +1319,102 @@
@end lisp
@end defun
+ at node Package-Local Nicknames
+ at section Package-Local Nicknames
+
+ABCL allows giving packages local nicknames: they allow short and
+easy-to-use names to be used without fear of name conflict associated
+with normal nicknames. at footnote{Package-local nicknames were originally
+developed in SBCL.}
+
+A local nickname is valid only when inside the package for which it
+has been specified. Different packages can use same local nickname for
+different global names, or different local nickname for same global
+name.
+
+Symbol @code{:package-local-nicknames} in @code{*features*} denotes the
+support for this feature.
+
+ at defmac defpackage name [[option]]* @result{} package
+
+Options are extended to include
+
+ at itemize
+ at item
+ at code{:local-nicknames} @var{(local-nickname actual-package-name)}*
+
+The package has the specified local nicknames for the corresponding
+actual packages.
+ at end itemize
+
+Example:
+
+ at lisp
+(defpackage :bar (:intern "X"))
+(defpackage :foo (:intern "X"))
+(defpackage :quux (:use :cl) (:local-nicknames (:bar :foo) (:foo :bar)))
+(find-symbol "X" :foo) ; => FOO::X
+(find-symbol "X" :bar) ; => BAR::X
+(let ((*package* (find-package :quux)))
+ (find-symbol "X" :foo)) ; => BAR::X
+(let ((*package* (find-package :quux)))
+ (find-symbol "X" :bar)) ; => FOO::X
+ at end lisp
+ at end defmac
+
+ at defun package-local-nicknames (package-designator)
+
+Returns an alist of (local-nickname . actual-package) describing the
+nicknames local to the designated package.
+
+When in the designated package, calls to @code{find-package} with any of
+the local-nicknames will return the corresponding actual-package
+instead. This also affects all implied calls to @code{find-package},
+including those performed by the reader.
+
+When printing a package prefix for a symbol with a package local
+nickname, the local nickname is used instead of the real name in order
+to preserve print-read consistency.
+ at end defun
+
+ at defun package-locally-nicknamed-by-list (package-designator)
+
+Returns a list of packages which have a local nickname for the
+designated package.
+ at end defun
+
+ at defun add-package-local-nickname (local-nickname actual-package &optional package-designator)
+
+Adds @code{local-nickname} for @code{actual-package} in the designated
+package, defaulting to current package. @code{local-nickname} must be a
+string designator, and @code{actual-package} must be a package
+designator.
+
+Returns the designated package.
+
+Signals an error if @code{local-nickname} is already a package local
+nickname for a different package, or if @code{local-nickname} is one of
+"CL", "COMMON-LISP", or, "KEYWORD", or if @code{local-nickname} is a
+global name or nickname for the package to which the nickname would be
+added.
+
+When in the designated package, calls to @code{find-package} with the
+ at code{local-nickname} will return the package the designated
+ at code{actual-package} instead. This also affects all implied calls to
+ at code{find-package}, including those performed by the reader.
+
+When printing a package prefix for a symbol with a package local nickname,
+local nickname is used instead of the real name in order to preserve
+print-read consistency.
+ at end defun
+
+ at defun remove-package-local-nickname (old-nickname &optional package-designator)
+
+If the designated package had @code{old-nickname} as a local nickname
+for another package, it is removed. Returns true if the nickname existed
+and was removed, and @code{nil} otherwise.
+ at end defun
+
@node Extensible Sequences
@section Extensible Sequences
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -1839,7 +1839,7 @@
{
if (obj instanceof Package)
return (Package) obj;
- Package pkg = Packages.findPackage(javaString(obj));
+ Package pkg = getCurrentPackage().findPackage(javaString(obj));
if (pkg != null)
return pkg;
error(new PackageError(obj.princToString() + " is not the name of a package."));
@@ -2147,7 +2147,7 @@
public static final Symbol internInPackage(String name, String packageName)
{
- Package pkg = Packages.findPackage(packageName);
+ Package pkg = getCurrentPackage().findPackage(packageName);
if (pkg == null)
error(new LispError(packageName + " is not the name of a package."));
return pkg.intern(name);
@@ -2338,7 +2338,8 @@
// Common features
LispObject featureList = list(Keyword.ARMEDBEAR, Keyword.ABCL,
Keyword.COMMON_LISP, Keyword.ANSI_CL,
- Keyword.CDR6, Keyword.MOP);
+ Keyword.CDR6, Keyword.MOP,
+ internKeyword("PACKAGE-LOCAL-NICKNAMES"));
// OS type
if (osName.startsWith("Linux"))
featureList = Primitives.APPEND.execute(list(Keyword.UNIX,
Modified: trunk/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Load.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/Load.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -375,7 +375,7 @@
// ### *fasl-version*
// internal symbol
static final Symbol _FASL_VERSION_ =
- exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(39));
+ exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(40));
// ### *fasl-external-format*
// internal symbol
Modified: trunk/abcl/src/org/armedbear/lisp/Package.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Package.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/Package.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -38,6 +38,7 @@
import java.util.ArrayList;
import java.util.Collection;
import java.util.HashMap;
+import java.util.Map;
import java.util.Iterator;
import java.util.List;
import java.util.concurrent.ConcurrentHashMap;
@@ -63,6 +64,7 @@
private transient ArrayList<String> nicknames;
private transient LispObject useList = null;
private transient ArrayList<Package> usedByList = null;
+ private transient ConcurrentHashMap<String, Package> localNicknames;
// Anonymous package.
public Package()
@@ -758,6 +760,67 @@
return list;
}
+ public LispObject getLocalPackageNicknames()
+ {
+ LispObject list = NIL;
+ if (localNicknames != null) {
+ for (Map.Entry<String, Package> entry : localNicknames.entrySet()) {
+ list = new Cons(new Cons(entry.getKey(), entry.getValue()), list);
+ }
+ }
+ return list;
+ }
+
+ public LispObject addLocalPackageNickname(String name, Package pack)
+ {
+ if (name.equals("CL") || name.equals("COMMON-LISP")
+ || name.equals("KEYWORD")) {
+ return error(new LispError("Trying to define a local nickname for "
+ + name));
+ }
+ if (name.equals(this.name) || nicknames.contains(name)) {
+ return error(new LispError("Trying to override package name or nickname with a local nickname "
+ + name));
+ }
+ if (localNicknames == null) {
+ localNicknames = new ConcurrentHashMap<String, Package>();
+ }
+ if (localNicknames.containsKey(name)) {
+ return error(new LispError(name + " is already a nickname for "
+ + pack.getName()));
+ } else {
+ localNicknames.put(name, pack);
+ return pack;
+ }
+ }
+
+ public LispObject removeLocalPackageNickname(String name)
+ {
+ if (localNicknames == null || !localNicknames.containsKey(name)) {
+ return NIL;
+ } else {
+ // return generalized boolean: package that was nicknamed to `name'
+ return localNicknames.remove(name);
+ }
+ }
+
+ public Collection<Package> getLocallyNicknamedPackages()
+ {
+ // for implementing package-locally-nicknamed-by-list
+ if (localNicknames == null) return new ArrayList<Package>();
+ else return localNicknames.values();
+ }
+
+ // Find package named `name', taking local nicknames into account
+ public Package findPackage(String name)
+ {
+ if (localNicknames != null) {
+ Package pkg = localNicknames.get(name);
+ if (pkg != null) return pkg;
+ }
+ return Packages.findPackageGlobally(name);
+ }
+
public LispObject getShadowingSymbols()
{
LispObject list = NIL;
@@ -878,7 +941,7 @@
}
public Object readResolve() throws java.io.ObjectStreamException {
- Package pkg = Packages.findPackage(name);
+ Package pkg = findPackage(name);
if(pkg != null) {
return pkg;
} else {
Modified: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -270,6 +270,69 @@
}
};
+ // ### package-local-nicknames
+ // package-local-nicknames package => nickname-alist
+ private static final Primitive PACKAGE_LOCAL_NICKNAMES =
+ new Primitive("package-local-nicknames", PACKAGE_EXT, true, "package")
+ {
+ @Override
+ public LispObject execute(LispObject arg)
+ {
+ return coerceToPackage(arg).getLocalPackageNicknames();
+ }
+ };
+
+ // ### add-package-local-nickname
+ // add-package-local-nickname local-nickname package &optional package-designator => package
+ private static final Primitive ADD_PACKAGE_LOCAL_NICKNAME =
+ new Primitive("add-package-local-nickname", PACKAGE_EXT, true,
+ "local-nickname package &optional package-designator")
+ {
+ @Override
+ public LispObject execute(LispObject nick, LispObject pack,
+ LispObject target)
+ {
+ return coerceToPackage(target).addLocalPackageNickname(nick.getStringValue(), coerceToPackage(pack));
+ }
+ @Override
+ public LispObject execute(LispObject nick, LispObject pack)
+ {
+ return this.execute(nick, pack, getCurrentPackage());
+ }
+ };
+
+ // ### remove-package-local-nickname
+ // remove-package-local-nickname old-nickname &optional package-designator => boolean
+ private static final Primitive REMOVE_PACKAGE_LOCAL_NICKNAME =
+ new Primitive("remove-package-local-nickname", PACKAGE_EXT, true,
+ "old-nickname &optional package-designator")
+ {
+ @Override
+ public LispObject execute(LispObject nick, LispObject target)
+ {
+ return coerceToPackage(target).removeLocalPackageNickname(nick.getStringValue());
+ }
+ @Override
+ public LispObject execute(LispObject nick)
+ {
+ return this.execute(nick, getCurrentPackage());
+ }
+ };
+
+ // ### package-locally-nicknamed-by-list
+ // package-locally-nicknamed-by-list package => package-list
+ private static final Primitive PACKAGE_LOCALLY_NICKNAMED_BY_LIST =
+ new Primitive("package-locally-nicknamed-by-list", PACKAGE_EXT, true,
+ "package")
+ {
+ @Override
+ public LispObject execute(LispObject pack)
+ {
+ return Packages.getPackagesNicknamingPackage(coerceToPackage(pack));
+ }
+ };
+
+
// ### %defpackage name nicknames size shadows shadowing-imports use
// imports interns exports doc-string => package
private static final Primitive _DEFPACKAGE =
@@ -278,9 +341,10 @@
@Override
public LispObject execute(LispObject[] args)
{
- if (args.length != 10)
- return error(new WrongNumberOfArgumentsException(this, 10));
+ if (args.length != 11)
+ return error(new WrongNumberOfArgumentsException(this, 11));
final String packageName = args[0].getStringValue();
+ Package currentpkg = getCurrentPackage();
LispObject nicknames = checkList(args[1]);
// FIXME size is ignored
// LispObject size = args[2];
@@ -290,16 +354,17 @@
LispObject imports = checkList(args[6]);
LispObject interns = checkList(args[7]);
LispObject exports = checkList(args[8]);
+ LispObject localNicknames = checkList(args[9]);
// FIXME docString is ignored
- // LispObject docString = args[9];
- Package pkg = Packages.findPackage(packageName);
+ // LispObject docString = args[10];
+ Package pkg = currentpkg.findPackage(packageName);
if (pkg != null)
return pkg;
if (nicknames != NIL) {
LispObject list = nicknames;
while (list != NIL) {
String nick = javaString(list.car());
- if (Packages.findPackage(nick) != null) {
+ if (currentpkg.findPackage(nick) != null) {
return error(new PackageError("A package named " + nick +
" already exists."));
}
@@ -340,7 +405,7 @@
pkg.usePackage((Package)obj);
else {
LispObject string = obj.STRING();
- Package p = Packages.findPackage(string.getStringValue());
+ Package p = currentpkg.findPackage(string.getStringValue());
if (p == null)
return error(new LispError(obj.princToString() +
" is not the name of a package."));
@@ -375,6 +440,13 @@
pkg.export(pkg.intern(symbolName));
exports = exports.cdr();
}
+ while (localNicknames != NIL) {
+ LispObject nickDecl = localNicknames.car();
+ String name = nickDecl.car().getStringValue();
+ Package pack = coerceToPackage(nickDecl.cadr());
+ pkg.addLocalPackageNickname(name, pack);
+ localNicknames = localNicknames.cdr();
+ }
return pkg;
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/Packages.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Packages.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/Packages.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -86,8 +86,10 @@
}
}
- // Returns null if package doesn't exist.
- public static final synchronized Package findPackage(String name)
+ // Finds package named `name'. Returns null if package doesn't exist.
+ // Called by Package.findPackage after checking package-local package
+ // nicknames.
+ static final synchronized Package findPackageGlobally(String name)
{
return (Package) map.get(name);
}
@@ -144,11 +146,9 @@
public static final synchronized LispObject listAllPackages()
{
LispObject result = NIL;
- for (Iterator it = packages.iterator(); it.hasNext();)
- {
- Package pkg = (Package) it.next();
- result = new Cons(pkg, result);
- }
+ for (Package pkg : packages) {
+ result = new Cons(pkg, result);
+ }
return result;
}
@@ -158,4 +158,17 @@
packages.toArray(array);
return array;
}
+
+ public static final synchronized LispObject getPackagesNicknamingPackage(Package thePackage)
+ {
+ LispObject result = NIL;
+ for (Package pkg : packages) {
+ for (Package nicknamedPackage : pkg.getLocallyNicknamedPackages()) {
+ if (thePackage.equals(nicknamedPackage)) {
+ result = new Cons(pkg, result);
+ }
+ }
+ }
+ return result;
+ }
}
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -3177,17 +3177,17 @@
return arg;
if (arg instanceof AbstractString) {
Package pkg =
- Packages.findPackage(arg.getStringValue());
+ getCurrentPackage().findPackage(arg.getStringValue());
return pkg != null ? pkg : NIL;
}
if (arg instanceof Symbol) {
- Package pkg = Packages.findPackage(checkSymbol(arg).getName());
+ Package pkg = getCurrentPackage().findPackage(checkSymbol(arg).getName());
return pkg != null ? pkg : NIL;
}
if (arg instanceof LispCharacter) {
String packageName =
String.valueOf(new char[] {((LispCharacter)arg).getValue()});
- Package pkg = Packages.findPackage(packageName);
+ Package pkg = getCurrentPackage().findPackage(packageName);
return pkg != null ? pkg : NIL;
}
return NIL;
@@ -3222,7 +3222,8 @@
{
String packageName = javaString(first);
- Package pkg = Packages.findPackage(packageName);
+ Package currentpkg = getCurrentPackage();
+ Package pkg = currentpkg.findPackage(packageName);
if (pkg != null)
error(new LispError("Package " + packageName +
" already exists."));
@@ -3231,7 +3232,7 @@
LispObject list = nicknames;
while (list != NIL) {
String nick = javaString(list.car());
- if (Packages.findPackage(nick) != null) {
+ if (currentpkg.findPackage(nick) != null) {
error(new PackageError("A package named " + nick +
" already exists."));
}
@@ -3247,7 +3248,7 @@
// OK.
} else {
String s = javaString(obj);
- Package p = Packages.findPackage(s);
+ Package p = currentpkg.findPackage(s);
if (p == null) {
error(new LispError(obj.princToString() +
" is not the name of a package."));
@@ -3272,7 +3273,7 @@
pkg.usePackage((Package)obj);
else {
String s = javaString(obj);
- Package p = Packages.findPackage(s);
+ Package p = currentpkg.findPackage(s);
if (p == null) {
error(new LispError(obj.princToString() +
" is not the name of a package."));
@@ -3296,7 +3297,7 @@
@Override
public LispObject execute(LispObject arg) {
final String packageName = javaString(arg);
- final Package pkg = Packages.findPackage(packageName);
+ final Package pkg = getCurrentPackage().findPackage(packageName);
if (pkg == null)
return error(new PackageError("The name " + packageName +
" does not designate any package."));
Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/Stream.java Fri Mar 1 03:26:24 2013 (r14405)
@@ -1175,7 +1175,7 @@
if (invert)
packageName = invert(packageName, packageFlags);
- pkg = Packages.findPackage(packageName);
+ pkg = getCurrentPackage().findPackage(packageName);
if (pkg == null)
return error(new ReaderError("The package \"" + packageName + "\" can't be found.", this));
}
Modified: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Tue Feb 26 08:13:50 2013 (r14404)
+++ trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Fri Mar 1 03:26:24 2013 (r14405)
@@ -64,75 +64,90 @@
(defmacro defpackage (package &rest options)
(let ((nicknames nil)
- (size nil)
- (shadows nil)
- (shadowing-imports nil)
- (use nil)
- (use-p nil)
- (imports nil)
- (interns nil)
- (exports nil)
- (doc nil))
+ (size nil)
+ (shadows nil)
+ (shadowing-imports nil)
+ (use nil)
+ (use-p nil)
+ (imports nil)
+ (interns nil)
+ (exports nil)
+ (local-nicknames nil)
+ (doc nil))
(dolist (option options)
(unless (consp option)
- (error 'program-error "bad DEFPACKAGE option: ~S" option))
+ (error 'program-error "bad DEFPACKAGE option: ~S" option))
(case (car option)
- (:nicknames
- (setq nicknames (stringify-names (cdr option))))
- (:size
- (cond (size
- (error 'program-error "can't specify :SIZE twice"))
- ((and (consp (cdr option))
- (typep (second option) 'unsigned-byte))
- (setq size (second option)))
- (t
- (error 'program-error
- "bad :SIZE, must be a positive integer: ~S"
- (second option)))))
- (:shadow
- (let ((new (stringify-names (cdr option))))
- (setq shadows (append shadows new))))
- (:shadowing-import-from
- (let ((package-name (designated-package-name (cadr option)))
- (symbol-names (stringify-names (cddr option))))
- (let ((assoc (assoc package-name shadowing-imports
- :test #'string=)))
- (if assoc
- (setf (cdr assoc) (append (cdr assoc) symbol-names))
- (setq shadowing-imports
- (acons package-name symbol-names shadowing-imports))))))
- (:use
- (let ((new (mapcar #'designated-package-name (cdr option))))
- (setq use (delete-duplicates (nconc use new) :test #'string=))
- (setq use-p t)))
- (:import-from
- (let ((package-name (designated-package-name (cadr option)))
- (symbol-names (stringify-names (cddr option))))
- (let ((assoc (assoc package-name imports
- :test #'string=)))
- (if assoc
- (setf (cdr assoc) (append (cdr assoc) symbol-names))
- (setq imports (acons package-name symbol-names imports))))))
- (:intern
- (let ((new (stringify-names (cdr option))))
- (setq interns (append interns new))))
- (:export
- (let ((new (stringify-names (cdr option))))
- (setq exports (append exports new))))
- (:documentation
- (when doc
- (error 'program-error "can't specify :DOCUMENTATION twice"))
- (setq doc (coerce (cadr option) 'simple-string)))
- (t
- (error 'program-error "bad DEFPACKAGE option: ~S" option))))
+ (:nicknames
+ (setq nicknames (stringify-names (cdr option))))
+ (:size
+ (cond (size
+ (error 'program-error "can't specify :SIZE twice"))
+ ((and (consp (cdr option))
+ (typep (second option) 'unsigned-byte))
+ (setq size (second option)))
+ (t
+ (error 'program-error
+ "bad :SIZE, must be a positive integer: ~S"
+ (second option)))))
+ (:shadow
+ (let ((new (stringify-names (cdr option))))
+ (setq shadows (append shadows new))))
+ (:shadowing-import-from
+ (let ((package-name (designated-package-name (cadr option)))
+ (symbol-names (stringify-names (cddr option))))
+ (let ((assoc (assoc package-name shadowing-imports
+ :test #'string=)))
+ (if assoc
+ (setf (cdr assoc) (append (cdr assoc) symbol-names))
+ (setq shadowing-imports
+ (acons package-name symbol-names shadowing-imports))))))
+ (:use
+ (let ((new (mapcar #'designated-package-name (cdr option))))
+ (setq use (delete-duplicates (nconc use new) :test #'string=))
+ (setq use-p t)))
+ (:import-from
+ (let ((package-name (designated-package-name (cadr option)))
+ (symbol-names (stringify-names (cddr option))))
+ (let ((assoc (assoc package-name imports
+ :test #'string=)))
+ (if assoc
+ (setf (cdr assoc) (append (cdr assoc) symbol-names))
+ (setq imports (acons package-name symbol-names imports))))))
+ (:intern
+ (let ((new (stringify-names (cdr option))))
+ (setq interns (append interns new))))
+ (:export
+ (let ((new (stringify-names (cdr option))))
+ (setq exports (append exports new))))
+ (:documentation
+ (when doc
+ (error 'program-error "can't specify :DOCUMENTATION twice"))
+ (setq doc (coerce (cadr option) 'simple-string)))
+ (:local-nicknames
+ (dolist (nickdecl (cdr option))
+ (unless (= (length nickdecl) 2)
+ (error 'program-error "Malformed local nickname declaration ~A"
+ nickdecl))
+ (let ((nickname (string (first nickdecl)))
+ (package-name (designated-package-name (second nickdecl))))
+ (when (member package-name '("CL" "COMMON-LISP" "KEYWORD")
+ :test #'string-equal)
+ (cerror "Continue anyway"
+ (format nil "Trying to define a local nickname for package ~A"
+ package-name)))
+ (push (list nickname package-name) local-nicknames))))
+ (t
+ (error 'program-error "bad DEFPACKAGE option: ~S" option))))
(check-disjoint `(:intern , at interns) `(:export , at exports))
(check-disjoint `(:intern , at interns)
- `(:import-from
- ,@(apply #'append (mapcar #'rest imports)))
- `(:shadow , at shadows)
- `(:shadowing-import-from
- ,@(apply #'append (mapcar #'rest shadowing-imports))))
+ `(:import-from
+ ,@(apply #'append (mapcar #'rest imports)))
+ `(:shadow , at shadows)
+ `(:shadowing-import-from
+ ,@(apply #'append (mapcar #'rest shadowing-imports))))
`(%defpackage ,(string package) ',nicknames ',size
',shadows (ensure-available-symbols ',shadowing-imports)
',(if use-p use nil)
- (ensure-available-symbols ',imports) ',interns ',exports ',doc)))
+ (ensure-available-symbols ',imports) ',interns ',exports
+ ',local-nicknames ',doc)))
More information about the armedbear-cvs
mailing list