Support package-local nicknames

- Same API as SBCL (see manual)

- fasl version increased because arglist of %defpackage changed
parent 9ec34080
......@@ -956,6 +956,105 @@ expect the following:
\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}
......
......@@ -1319,6 +1319,102 @@ The specific subtype of a Pathname may be determined with the predicates
@end lisp
@end defun
@node Package-Local Nicknames
@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.@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.
@defmac defpackage name [[option]]* @result{} package
Options are extended to include
@itemize
@item
@code{:local-nicknames} @var{(local-nickname actual-package-name)}*
The package has the specified local nicknames for the corresponding
actual packages.
@end itemize
Example:
@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 lisp
@end defmac
@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.
@end defun
@defun package-locally-nicknamed-by-list (package-designator)
Returns a list of packages which have a local nickname for the
designated package.
@end defun
@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
@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 defun
@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.
@end defun
@node Extensible Sequences
@section Extensible Sequences
......
......@@ -1839,7 +1839,7 @@ public final class Lisp
{
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 final class Lisp
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 @@ public final class Lisp
// 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,
......
......@@ -375,7 +375,7 @@ public final class Load
// ### *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
......
......@@ -38,6 +38,7 @@ import static org.armedbear.lisp.Lisp.*;
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 @@ public final class Package extends LispObject implements java.io.Serializable
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 @@ public final class Package extends LispObject implements java.io.Serializable
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 final class Package extends LispObject implements java.io.Serializable
}
public Object readResolve() throws java.io.ObjectStreamException {
Package pkg = Packages.findPackage(name);
Package pkg = findPackage(name);
if(pkg != null) {
return pkg;
} else {
......
......@@ -270,6 +270,69 @@ public final class PackageFunctions
}
};
// ### 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 @@ public final class PackageFunctions
@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 @@ public final class PackageFunctions
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 @@ public final class PackageFunctions
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 @@ public final class PackageFunctions
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;
}
};
......
......@@ -86,8 +86,10 @@ public final class Packages
}
}
// 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 final class Packages
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 @@ public final class Packages
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;
}
}
......@@ -3177,17 +3177,17 @@ public final class Primitives {
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 @@ public final class Primitives {
{
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 @@ public final class Primitives {
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 @@ public final class Primitives {
// 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 @@ public final class Primitives {
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 @@ public final class Primitives {
@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."));
......
......@@ -1175,7 +1175,7 @@ public class Stream extends StructureObject {
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));
}
......
......@@ -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))))