From rschlatte at common-lisp.net Fri Mar 1 11:26:31 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 01 Mar 2013 03:26:31 -0800 Subject: [armedbear-cvs] r14405 - in trunk/abcl: doc/manual src/org/armedbear/lisp Message-ID: 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 nicknames; private transient LispObject useList = null; private transient ArrayList usedByList = null; + private transient ConcurrentHashMap localNicknames; // Anonymous package. public Package() @@ -758,6 +760,67 @@ return list; } + public LispObject getLocalPackageNicknames() + { + LispObject list = NIL; + if (localNicknames != null) { + for (Map.Entry 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(); + } + 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 getLocallyNicknamedPackages() + { + // for implementing package-locally-nicknamed-by-list + if (localNicknames == null) return new ArrayList(); + 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))) From mevenson at common-lisp.net Fri Mar 1 13:42:23 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 01 Mar 2013 05:42:23 -0800 Subject: [armedbear-cvs] r14406 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Mar 1 05:42:21 2013 New Revision: 14406 Log: The LispThread stack no longer grows inconsistently from errors thrown in implementation Java code. Fixes #304. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Fri Mar 1 03:26:24 2013 (r14405) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Fri Mar 1 05:42:21 2013 (r14406) @@ -607,6 +607,10 @@ public final void popStackFrame() { + // Pop off intervening JavaFrames until we get back to a LispFrame + while (stack != null && stack instanceof JavaStackFrame) { + stack = stack.getNext(); + } if (stack != null) stack = stack.getNext(); } From ehuelsmann at common-lisp.net Fri Mar 1 20:47:39 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 01 Mar 2013 12:47:39 -0800 Subject: [armedbear-cvs] r14407 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 1 12:47:38 2013 New Revision: 14407 Log: Specify opcode argument types to help programmers generate class files using jvm-class-file.lisp -- in a later stage. Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Fri Mar 1 05:42:21 2013 (r14406) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Fri Mar 1 12:47:38 2013 (r14407) @@ -72,22 +72,52 @@ (defconst *opcodes* (make-hash-table :test 'equalp)) -(defstruct jvm-opcode name number size stack-effect register-used) +;; instruction arguments are encoded as part of the instruction, +;; we're not talking stack values here. -(defun %define-opcode (name number size stack-effect register) +;; b = signed byte (8-bit) +;; B = unsigned byte (8-bit) +;; w = signed word (16-bit) +;; W = unsigned word (16-bit) +;; i = signed int (32-bit) +;; I = unsigend int (32-bit) + +;; o = signed offset (relative code pointer) (16-bit) +;; p = pool index (unsigned 8-bit) +;; P = pool index (unsigned 16-bit) +;; l = local variable (8-bit) +;; L = local variable (16-bit) + +;; z = zero padding (1 to 3 bytes) to guarantee 4-byte alignment +;; of the following arguments +;; q = lookupswitch variable length instruction arguments +;; Q = tableswitch variable length instruction arguments + +;; t = 8-bit java builtin type designator (in {4,5,6,7,8,9,10,11}) + + +(defstruct jvm-opcode name number size stack-effect register-used + (args-spec "")) + +(defun %define-opcode (name number size stack-effect register + &optional args-spec) (declare (type fixnum number size)) (let* ((name (string name)) (opcode (make-jvm-opcode :name name :number number :size size :stack-effect stack-effect - :register-used register))) + :register-used register + :args-spec args-spec))) (setf (svref *opcode-table* number) opcode) (setf (gethash name *opcodes*) opcode) (setf (gethash number *opcodes*) opcode))) -(defmacro define-opcode (name number size stack-effect register) - `(%define-opcode ',name ,number ,size ,stack-effect ,register)) +(defmacro define-opcode (name number size stack-effect register + &optional args-spec) + `(%define-opcode ',name ,number ,size ,stack-effect ,register + ,@(when args-spec + (list args-spec)))) ;; name number size stack-effect register-used (define-opcode nop 0 1 0 nil) @@ -108,9 +138,9 @@ (define-opcode dconst_1 15 1 2 nil) (define-opcode bipush 16 2 1 nil) (define-opcode sipush 17 3 1 nil) -(define-opcode ldc 18 2 1 nil) -(define-opcode ldc_w 19 3 1 nil) -(define-opcode ldc2_w 20 3 2 nil) +(define-opcode ldc 18 2 1 nil "p") +(define-opcode ldc_w 19 3 1 nil "P") +(define-opcode ldc2_w 20 3 2 nil "P") (define-opcode iload 21 2 1 t) (define-opcode lload 22 2 2 t) (define-opcode fload 23 2 nil t) @@ -269,22 +299,22 @@ (define-opcode ireturn 172 1 -1 nil) (define-opcode areturn 176 1 -1 nil) (define-opcode return 177 1 0 nil) -(define-opcode getstatic 178 3 1 nil) -(define-opcode putstatic 179 3 -1 nil) -(define-opcode getfield 180 3 0 nil) -(define-opcode putfield 181 3 -2 nil) -(define-opcode invokevirtual 182 3 nil nil) -(define-opcode invokespecial 183 3 nil nil) -(define-opcode invokestatic 184 3 nil nil) -(define-opcode invokeinterface 185 5 nil nil) +(define-opcode getstatic 178 3 1 nil "P") +(define-opcode putstatic 179 3 -1 nil "P") +(define-opcode getfield 180 3 0 nil "P") +(define-opcode putfield 181 3 -2 nil "P") +(define-opcode invokevirtual 182 3 nil nil "P") +(define-opcode invokespecial 183 3 nil nil "P") +(define-opcode invokestatic 184 3 nil nil "P") +(define-opcode invokeinterface 185 5 nil nil "P") (define-opcode unused 186 0 nil nil) -(define-opcode new 187 3 1 nil) +(define-opcode new 187 3 1 nil "P") (define-opcode newarray 188 2 nil nil) (define-opcode anewarray 189 3 0 nil) (define-opcode arraylength 190 1 0 nil) (define-opcode athrow 191 1 0 nil) -(define-opcode checkcast 192 3 0 nil) -(define-opcode instanceof 193 3 0 nil) +(define-opcode checkcast 192 3 0 nil "P") +(define-opcode instanceof 193 3 0 nil "P") (define-opcode monitorenter 194 1 -1 nil) (define-opcode monitorexit 195 1 -1 nil) (define-opcode wide 196 0 nil nil) @@ -325,6 +355,9 @@ (declare (optimize speed)) (jvm-opcode-stack-effect (svref *opcode-table* opcode-number))) +(defun opcode-args-spec (opcode-number) + (let ((opcode (gethash opcode-number *opcodes*))) + (and opcode (jvm-opcode-args-spec)))) @@ -806,22 +839,13 @@ (when (eql opcode 202) ; LABEL (let ((label (car (instruction-args instruction)))) (set label i))) - (if (instruction-stack instruction) - (when (opcode-stack-effect opcode) - (unless (eql (instruction-stack instruction) - (opcode-stack-effect opcode)) - (sys::%format t "instruction-stack = ~S ~ - opcode-stack-effect = ~S~%" - (instruction-stack instruction) - (opcode-stack-effect opcode)) - (sys::%format t "index = ~D instruction = ~A~%" i - (print-instruction instruction)))) - (setf (instruction-stack instruction) - (opcode-stack-effect opcode))) (unless (instruction-stack instruction) - (sys::%format t "no stack information for instruction ~D~%" - (instruction-opcode instruction)) - (aver nil)))) + (setf (instruction-stack instruction) + (opcode-stack-effect opcode)) + (unless (instruction-stack instruction) + (sys::%format t "no stack information for instruction ~D~%" + (instruction-opcode instruction)) + (aver nil))))) (analyze-stack-path code 0 0) (dolist (entry-point exception-entry-points) ;; Stack depth is always 1 when handler is called. @@ -1078,4 +1102,4 @@ (setf code (optimize-code code handler-labels pool))) (resolve-instructions (expand-virtual-instructions code))) -(provide '#:opcodes) +(provide '#:jvm-instructions) From mevenson at common-lisp.net Sat Mar 2 10:02:41 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 02 Mar 2013 02:02:41 -0800 Subject: [armedbear-cvs] r14408 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Sat Mar 2 02:02:38 2013 New Revision: 14408 Log: Manual merge of the Manual from 1.1.x. Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Fri Mar 1 12:47:38 2013 (r14407) +++ trunk/abcl/doc/manual/abcl.tex Sat Mar 2 02:02:38 2013 (r14408) @@ -8,9 +8,9 @@ \begin{document} \title{Armed Bear Common Lisp User Manual} -\date{Version 1.1.0\\ +\date{Version 1.2.0-dev\\ \smallskip -December 5, 2012} +March 2, 2013} \author{Mark Evenson \and Erik H\"{u}lsmann \and Rudolf Schlatte \and Alessio Stalla \and Ville Voutilainen} @@ -18,18 +18,19 @@ \tableofcontents -%%Preface to the second edition, abcl-1.1.0. +%%Preface to the second edition, abcl-1.1. \subsection{Preface to the Second Edition} -ABCL 1.1 now contains (A)MOP. We hope you enjoy! --The Mgmt. +\textsc{ABCL} 1.1 now contains \textsc{(A)MOP}. We hope you enjoy! --The Mgmt. \chapter{Introduction} -Armed Bear Common Lisp (ABCL) is an implementation of Common Lisp that -runs on the Java Virtual Machine. It compiles Common Lisp to Java 5 -bytecode, providing the following integration methods for interfacing -with Java code and libraries: +Armed Bear Common Lisp (\textsc{ABCL}) is an implementation of Common +Lisp that runs on the Java Virtual Machine. It compiles Common Lisp +to Java 5 bytecode \footnote{The class file version is ``49.0''.}, +providing the following integration methods for interfacing with Java +code and libraries: \begin{itemize} \item Lisp code can create Java objects and call their methods (see Section~\ref{sec:lisp-java}, page~\pageref{sec:lisp-java}). @@ -42,31 +43,31 @@ of Java interfaces that can be used as listeners for Swing classes and similar. \end{itemize} -ABCL is supported by the Lisp library manager -QuickLisp\footnote{\url{http://quicklisp.org/}} and can run many of the +\textsc{ABCL} is supported by the Lisp library manager +\textsc{QuickLisp}\footnote{\url{http://quicklisp.org/}} and can run many of the programs and libraries provided therein out-of-the-box. \section{Conformance} \label{section:conformance} \subsection{ANSI Common Lisp} -\textsc{ABCL} is currently a (non)-conforming ANSI Common Lisp +\textsc{ABCL} is currently a (non)-conforming \textsc{ANSI} Common Lisp implementation due to the following known issues: \begin{itemize} -\item The generic function signatures of the \code{DOCUMENTATION} symbol +\item The generic function signatures of the \code{CL:DOCUMENTATION} symbol do not match the specification. -\item The \code{TIME} form does not return a proper \code{VALUES} +\item The \code{CL:TIME} form does not return a proper \code{CL:VALUES} environment to its caller. -\item When merging pathnames and the defaults point to a \code{JAR-PATHNAME}, +\item When merging pathnames and the defaults point to a \code{EXT:JAR-PATHNAME}, we set the \code{DEVICE} of the result to \code{:UNSPECIFIC} if the pathname to be be merged does not contain a specified \code{DEVICE}, does not contain a specified \code{HOST}, does contain a relative \code{DIRECTORY}, and we are not running on a \textsc{MSFT} Windows platform.\footnote{The intent of this rather arcane sounding deviation from conformance is so that the - result of a merge won't fill in a DEVICE with the wrong "default + result of a merge won't fill in a \code{DEVICE} with the wrong "default device for the host" in the sense of the fourth paragraph in the - CLHS description of MERGE-PATHNAMES (see in \cite{CLHS} the paragraph beginning + \textsc{CLHS} description of MERGE-PATHNAMES (see in \cite{CLHS} the paragraph beginning "If the PATHNAME explicitly specifies a host and not a device?"). A future version of the implementation may return to conformance by using the \code{HOST} value to reflect the type explicitly. @@ -80,11 +81,11 @@ to the Common Lisp HyperSpec~\cite{CLHS}. Clarifications to this point are solicited. -ABCL aims to be be a fully conforming ANSI Common Lisp implementation. +\textsc{ABCL} aims to be be a fully conforming \textsc{ANSI} Common Lisp implementation. Any other behavior should be reported as a bug. \subsection{Contemporary Common Lisp} -In addition to ANSI conformance, \textsc{ABCL} strives to implement +In addition to \textsc{ANSI} conformance, \textsc{ABCL} strives to implement features expected of a contemporary Common Lisp, i.e. a Lisp of the post-2005 Renaissance. @@ -97,26 +98,29 @@ in a given call frame, and the inability to resume a halted computation at an arbitrarily selected call frame. \item Incomplete streams abstraction, in that \textsc{ABCL} needs - suitable abstraction between ANSI and Gray streams. The streams could - be optimized to the JVM NIO abstractions at great profit for binary - byte-level manipulations. -\item Incomplete documentation (missing docstrings from exported symbols - and the draft status of this user manual). + suitable abstraction between \textsc{ANSI} and Gray + streams. \footnote{The streams could be optimized to the + \textsc{JVM} NIO \cite{nio} abstractions at great profit for + binary byte-level manipulations.} +\item Incomplete documentation (missing docstrings from exported + symbols and the draft status of this user manual). \end{itemize} \section{License} -ABCL is licensed under the terms of the GPL v2 of June 1991 with the -``classpath-exception'' (see the file \texttt{COPYING} in the source -distribution for the license, term 13 in the same file for the classpath -exception). This license broadly means that you must distribute the -sources to ABCL, including any changes you make, together with a program -that includes ABCL, but that you are not required to distribute the -sources of the whole program. Submitting your changes upstream to the -ABCL development team is actively encouraged and very much appreciated, -of course. +\textsc{ABCL} is licensed under the terms of the \textsc{GPL} v2 of +June 1991 with the ``classpath-exception'' (see the file +\texttt{COPYING} in the source distribution \footnote{See + \url{http://svn.common-lisp.net/armedbear/trunk/abcl/COPYING}} for +the license, term 13 in the same file for the classpath exception). +This license broadly means that you must distribute the sources to +ABCL, including any changes you make, together with a program that +includes ABCL, but that you are not required to distribute the sources +of the whole program. Submitting your changes upstream to the ABCL +development team is actively encouraged and very much appreciated, of +course. \section{Contributors} @@ -132,11 +136,14 @@ \chapter{Running ABCL} + \textsc{ABCL} is packaged as a single jar file usually named either -\texttt{abcl.jar} or possibly something like \texttt{abcl-1.1.0.jar} if +\texttt{abcl.jar} or possibly something like \texttt{abcl-1.2.0.jar} if using a versioned package on the local filesystem from your system vendor. This jar file can be executed from the command line to obtain a -REPL\footnote{Read-Eval Print Loop, a Lisp command-line}, viz: +\textsc{REPL}\footnote{Read-Eval Print Loop, a Lisp command-line}, viz: + +\index{REPL} \begin{listing-shell} cmd$ java -jar abcl.jar @@ -156,13 +163,15 @@ \end{listing-shell}%$ Probably the easiest way of setting up an editing environment using the -Emacs editor is to use QuickLisp and follow the instructions at +\textsc{Emacs} editor is to use \textsc{Quicklisp} and follow the instructions at \url{http://www.quicklisp.org/beta/#slime}. \section{Options} ABCL supports the following command line options: +\index{Command Line Options} + \begin{description} \item[\texttt{ --help}] displays a help message. \item[\texttt{ --noinform}] Suppresses the printing of startup information and banner. @@ -173,7 +182,7 @@ \item[\texttt{ --load-system-file FILE}] loads the system file FILE before initializing the REPL. \item[\texttt{ --batch}] evaluates forms specified by arguments and in the initialization file \verb+~/.abclrc+, and then exits without - starting a REPL. + starting a \textsc{REPL}. \end{description} All of the command line arguments following the occurrence of \verb+--+ @@ -1086,15 +1095,16 @@ required. Note that \code{(require 'java-collections)} must be issued before -\code{java.util.List} or any subclass is used as a specializer in a CLOS +\code{java.util.List} or any subclass is used as a specializer in a \textsc{CLOS} method definition (see the section below). \section{Extensions to CLOS} \subsection{Metaobject Protocol} -ABCL implements the metaobject protocol for CLOS as specified in AMOP. -The symbols are exported from the package \code{MOP}. +\textsc{ABCL} implements the metaobject protocol for \textsc{CLOS} as +specified in \textsc{(A)MOP}. The symbols are exported from the +package \code{MOP}. \subsection{Specializing on Java classes} @@ -1155,7 +1165,8 @@ \begin{description} - \item{\code{ASDF}} Loads the \textsc{ASDF} implementation shipped + \item{\code{ASDF}} + Loads the \textsc{ASDF} implementation shipped with the implementation. After \textsc{ASDF} has been loaded in this manner, symbols passed to \code{CL:REQUIRE} which are otherwise unresolved, are passed to ASDF for a chance for @@ -1164,27 +1175,36 @@ 'cl-ppcre)} is equivalent to \code{(asdf:load-system 'cl-ppcre)}. - \item{\code{ABCL-CONTRIB}} Locates and pushes the toplevel contents of + \item{\code{ABCL-CONTRIB}} + Locates and pushes the toplevel contents of ``abcl-contrib.jar'' into the \textsc{ASDF} central registry. \begin{enumerate} - \item \code{abcl-asdf} - Functions for loading JVM artifacts dynamically, hooking into ASDF 2 objects where possible. - \item \code{asdf-jar} Package addressable JVM artifacts via + \item \code{abcl-asdf} + Functions for loading JVM artifacts + dynamically, hooking into ASDF 2 objects where possible. + \item \code{asdf-jar} + Package addressable JVM artifacts via \code{abcl-asdf} descriptions as a single binary artifact including recursive dependencies. - \item \code{mvn} - These systems name common JVM artifacts from the distributed pom.xml graph of Maven Aether: + \item \code{mvn} + These systems name common JVM artifacts from + the distributed pom.xml graph of Maven Aether: \begin{enumerate} - \item \code{jna} Dynamically load 'jna.jar' version 3.5.1 + \item \code{jna} + Dynamically load 'jna.jar' version 3.5.1 from the network \footnote{This loading can be inhibited if, at runtime, the Java class corresponding ``:classname'' clause of the system defition is present.} \end{enumerate} - \item \code{quicklisp-abcl} (Not working) boot a local Quicklisp - installation via the ASDF:IRI type introduced bia ABCL-ASDF. - - \end{enumerate} + \item \code{quicklisp-abcl} Boot a local Quicklisp installation + via the ASDF:IRI type introduced bia ABCL-ASDF. + +\begin{listing-lisp} +CL-USER> (asdf:load-system :quicklisp-abcl :force t) +\end{listing-lisp} + +\end{enumerate} \end{description} @@ -1194,7 +1214,7 @@ passed to \code{CL:REQUIRE} and returns a non-\code{NIL} value if it can successful resolve the symbol. -\section{JSS optionally extends the Reader} +\section{JSS extension of the Reader by SHARPSIGN-DOUBLE-QUOTE} The JSS contrib consitutes an additional, optional extension to the reader in the definition of the \code{SHARPSIGN-DOUBLE-QUOTE} @@ -1203,12 +1223,12 @@ \section{ASDF} -asdf-2.26.6 (see \cite{asdf}) is packaged as core component of ABCL, -but not initialized by default, as it relies on the CLOS subsystem +asdf-2.30 (see \cite{asdf}) is packaged as core component of \textsc{ABCL}, +but not initialized by default, as it relies on the \textsc{CLOS} subsystem which can take a bit of time to start \footnote{While this time is ``merely'' on the order of seconds for contemporary 2011 machines, for applications that need to initialize quickly, for example a web - server, this time might be unnecessarily long}. The packaged ASDF + server, this time might be unnecessarily long}. The packaged \textsc{ASDF} may be loaded by the \textsc{ANSI} \code{REQUIRE} mechanism as follows: @@ -1218,9 +1238,9 @@ \chapter{Contrib} -The ABCL contrib is packaged as a separate jar archive usually named +The \textsc{ABCL} contrib is packaged as a separate jar archive usually named \code{abcl-contrib.jar} or possibly something like -\code{abcl-contrib-1.1.0.jar}. The contrib jar is not loaded by the +\code{abcl-contrib-1.2.0.jar}. The contrib jar is not loaded by the implementation by default, and must be first intialized by the \code{REQUIRE} mechanism before using any specific contrib: @@ -1306,12 +1326,17 @@ Notice that all recursive dependencies have been located and installed locally from the network as well. +More extensive documentations and examples can be found at +\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/abcl-asdf/README.markdown}. + + \section{asdf-jar} -The asdf-jar contrib provides a system for packaging ASDF systems into -jar archives for ABCL. Given a running ABCL image with loadable ASDF -systems the code in this package will recursively package all the -required source and fasls in a jar archive. +The asdf-jar contrib provides a system for packaging \textsc{ASDF} +systems into jar archives for \textsc{ABCL}. Given a running +\textsc{ABCL} image with loadable \textsc{ASDF} systems the code in +this package will recursively package all the required source and +fasls in a jar archive. The documentation for this contrib can be found at \url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown}. @@ -1357,6 +1382,9 @@ The contrib contains a pure-Java version of JFLI. +\url{http://svn.common-lisp.net/armedbear/tags/trunk/abcl/contrib/jfli/README}. + + \section{asdf-install} The asdf-install contrib provides an implementation of ASDF-INSTALL. @@ -1369,7 +1397,11 @@ stashing \textsc{ABCL} specific system definitions for convenient access. +\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-install/README}. + + \chapter{History} +\index{History} \textsc{ABCL} was originally the extension language for the J editor, which was started in 1998 by Peter Graves. Sometime in 2003, a whole lot of @@ -1390,8 +1422,9 @@ released abcl-1.0.0. We released abcl-1.0.1 as a maintainence release on January 10, 2012. -In December 2012, we revised the implementation by adding (A)MOP -with the release of abcl-1.1.0. +In December 2012, we revised the implementation by adding +\textsc{(A)MOP} with the release of abcl-1.1.0. We released +abcl-1.1.1 as a maintainence release on Feburary 14, 2013. \appendix @@ -1402,7 +1435,7 @@ \chapter{The SYSTEM Dictionary} The public interfaces in this package are subject to change with -ABCL 1.2. +\textsc{ABCL} 1.2. \include{system} @@ -1412,7 +1445,6 @@ \include{jss} - \bibliography{abcl} \bibliographystyle{alpha} From mevenson at common-lisp.net Sat Mar 2 10:26:07 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 02 Mar 2013 02:26:07 -0800 Subject: [armedbear-cvs] r14409 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Sat Mar 2 02:26:06 2013 New Revision: 14409 Log: Manual typos, language changes, reference correction. Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Sat Mar 2 02:02:38 2013 (r14408) +++ trunk/abcl/doc/manual/abcl.tex Sat Mar 2 02:26:06 2013 (r14409) @@ -834,23 +834,23 @@ ``understands''. By definition, support is built-in into the JVM to access the ``http'' and ``https'' schemes but additional protocol handlers may be installed at runtime by having \textsc{JVM} symbols -present in the sun.net.protocol.dynamic package. See \cite{maso2000} -for more details. +present in the \code{sun.net.protocol.dynamic} package. See +\cite{maso2000} for more details. \textsc{ABCL} has created specializations of the ANSI \code{CL:PATHNAME} object to enable to use of \textsc{URI}s to address dynamically loaded resources for the JVM. The \code{EXT:URL-PATHNAME} -specialization. has a corresponding \textsc{URI} whose canonical +specialization has a corresponding \textsc{URI} whose canonical representation is defined to be the \code{NAMESTRING} of the -Pathname. The \code{EXT:JAR-PATHNAME} extension further specializes -the the \code{EXT:URL-PATHNAME} to provide access to components of zip -archives. +\cpde{CL:PATHNAME}. The \code{EXT:JAR-PATHNAME} extension further +specializes the the \code{EXT:URL-PATHNAME} to provide access to +components of zip archives. % RDF description of type hierarchy % TODO Render via some LaTeX mode for graphviz? \begin{verbatim} @prefix ext: . - @prefix cl: . + @prefix cl: . a . a . @@ -877,22 +877,22 @@ underlying \textsc{URI} are discarded between resolutions (i.e. the implementation does not attempt to cache the results of current name resolution of the representing resource unless it is requested to be - resolved.) Upon resolution, any canoicalization procedures + resolved.) Upon resolution, any canonicalization procedures followed in resolving the resource (e.g. following redirects) are discarded. Users may programatically initiate a new, local - computation by applying the \code{CL:TRUENAME} function to a - \code{EXT:URL-PATHNAME} object. Depending on the reliablity and - properties of your local \textsc{REST} infrastructure, these results - may not necessarily be idempotent over time\footnote {See - \cite{evenson2011} for the draft of the publication of the - technical details}. + computation of the resolution of the resource by applying the + \code{CL:TRUENAME} function to a \code{EXT:URL-PATHNAME} object. + Depending on the reliablity and properties of your local + \textsc{REST} infrastructure, these results may not necessarily be + idempotent over time\footnote {See \cite{evenson2011} for the draft + of the publication of the technical details}. \end{itemize} The implementation of \code{EXT:URL-PATHNAME} allows the \textsc{ABCL} user to dynamically load code from the network. For example, -Quicklisp (\cite{quicklisp}) may be completely installed from the \textsc{REPL} -as the single form: +\textsc{Quicklisp} (\cite{quicklisp}) may be completely installed from +the \textsc{REPL} as the single form: \begin{listing-lisp} CL-USER> (load "http://beta.quicklisp.org/quicklisp.lisp") @@ -904,10 +904,12 @@ types able to be \code{CL:READ} for the \code{DEVICE} to return a possible \code{CONS} of \code{CL:PATHNAME} objects. %% citation from CLHS needed. -In order to ``smooth over'' the bit about types being \code{CL:READ} from -\code{CL:PATHNAME} components, we extend the semantics for the usual PATHNAME -merge semantics when \code{*DEFAULT-PATHNAME-DEFAULTS*} contains a -\code{EXT:JAR-PATHNAME}. +In order to ``smooth over'' the bit about types being \code{CL:READ} +from \code{CL:PATHNAME} components, we extend the semantics for the +usual PATHNAME merge semantics when \code{*DEFAULT-PATHNAME-DEFAULTS*} +contains a \code{EXT:JAR-PATHNAME} with the ``do what I mean'' +algorithim described in \ref{section:conformance} on page +\pageref{section:conformance}. %See \ref{_:quicklisp} on page \pageref{_:quicklisp}. @@ -1382,7 +1384,7 @@ The contrib contains a pure-Java version of JFLI. -\url{http://svn.common-lisp.net/armedbear/tags/trunk/abcl/contrib/jfli/README}. +\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/jfli/README}. \section{asdf-install} From ehuelsmann at common-lisp.net Sun Mar 3 21:32:05 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:32:05 -0800 Subject: [armedbear-cvs] r14410 - branches/generic-class-file Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:32:03 2013 New Revision: 14410 Log: Remove branch long merged to trunk. Deleted: branches/generic-class-file/ From ehuelsmann at common-lisp.net Sun Mar 3 21:36:03 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:36:03 -0800 Subject: [armedbear-cvs] r14411 - branches/variable-less-labels Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:36:00 2013 New Revision: 14411 Log: We have LABELS without variables now; delete a branch trying to achieve exactly that. Deleted: branches/variable-less-labels/ From ehuelsmann at common-lisp.net Sun Mar 3 21:41:01 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:41:01 -0800 Subject: [armedbear-cvs] r14412 - branches/typed-asm Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:41:00 2013 New Revision: 14412 Log: Create a branch to commit intermediate state for work done to allow tracking of the types stored in locals and on the stack; this work is assumed required for the type-checking verifier "format 50". Added: branches/typed-asm/ - copied from r14411, trunk/ From ehuelsmann at common-lisp.net Sun Mar 3 21:45:40 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:45:40 -0800 Subject: [armedbear-cvs] r14413 - branches/less-reflection Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:45:39 2013 New Revision: 14413 Log: In coordination with Alessio, delete outdated branch. Deleted: branches/less-reflection/ From ehuelsmann at common-lisp.net Sun Mar 3 21:46:55 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:46:55 -0800 Subject: [armedbear-cvs] r14414 - branches/invokedynamic Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:46:54 2013 New Revision: 14414 Log: In coordination with Alessio, delete outdated branch. Deleted: branches/invokedynamic/ From ehuelsmann at common-lisp.net Sun Mar 3 21:49:56 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:49:56 -0800 Subject: [armedbear-cvs] r14415 - branches/save-image Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:49:55 2013 New Revision: 14415 Log: In coordination with Alessio, delete outdated branch. Deleted: branches/save-image/ From ehuelsmann at common-lisp.net Sun Mar 3 21:52:39 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:52:39 -0800 Subject: [armedbear-cvs] r14416 - branches/fewer-executes Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:52:38 2013 New Revision: 14416 Log: In coordination with Ville, delete outdated branch. Deleted: branches/fewer-executes/ From ehuelsmann at common-lisp.net Sun Mar 3 21:57:42 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 13:57:42 -0800 Subject: [armedbear-cvs] r14417 - branches/typed-asm/abcl Message-ID: Author: ehuelsmann Date: Sun Mar 3 13:57:41 2013 New Revision: 14417 Log: Add a readme explaining the purpose of the branch. Added: branches/typed-asm/abcl/BRANCH-README Added: branches/typed-asm/abcl/BRANCH-README ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ branches/typed-asm/abcl/BRANCH-README Sun Mar 3 13:57:41 2013 (r14417) @@ -0,0 +1,21 @@ + + +Purpose +======= + +The purpose of the branch is to abstract a layer out of +compiler-pass2 to manage byte code emission, with stack and local +types tracked throughout the code emission. + +The result should be a layer which collects enough information +to be able to generate "format 50" class files. Additionally, +the layer should provide for a place to hook in other code +backends. + +Status +====== + +The branch is used to record my thoughts and progress on the matter +as well as discuss the general direction with co-developers. + +Actual code can be compiled, but isn't used so far. From ehuelsmann at common-lisp.net Sun Mar 3 22:02:51 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 14:02:51 -0800 Subject: [armedbear-cvs] r14418 - branches/typed-asm/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 3 14:02:50 2013 New Revision: 14418 Log: Commit progress: * Split out a number of functions from jvm-instructions to jvm-method * Create jvm-method to hold method generation functionality * Adjust autoloads-gen bootstrapping file to point existing symbols to the new jvm-method file * Add asserts all over the place to make sure we're generating valid output Added: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sun Mar 3 13:57:41 2013 (r14417) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sun Mar 3 14:02:50 2013 (r14418) @@ -103,7 +103,7 @@ ;; FUNCTIONS (IN-PACKAGE :JVM) -(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS ANALYZE-STACK-PATH ANALYZE-STACK ANALYZE-LOCALS DELETE-UNUSED-LABELS DELETE-UNREACHABLE-CODE LABEL-TARGET-INSTRUCTIONS OPTIMIZE-JUMPS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("jvm-method" ANALYZE-STACK-PATH ANALYZE-STACK LABEL-TARGET-INSTRUCTIONS DELETE-UNUSED-LABELS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-JUMPS DELETE-UNREACHABLE-CODE OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE)) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; MACROS Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp Sun Mar 3 13:57:41 2013 (r14417) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp Sun Mar 3 14:02:50 2013 (r14418) @@ -294,6 +294,7 @@ (load (do-compile "source-transform.lisp")) (load (do-compile "compiler-macro.lisp")) (load (do-compile "jvm-instructions.lisp")) + (load (do-compile "jvm-method.lisp")) (load (do-compile "setf.lisp")) (load (do-compile "extensible-sequences-base.lisp")) (load (do-compile "require.lisp")) Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 3 13:57:41 2013 (r14417) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 3 14:02:50 2013 (r14418) @@ -43,6 +43,7 @@ (require "DUMP-FORM") (require "JVM-INSTRUCTIONS") (require "JVM-CLASS-FILE") + (require "JVM-METHOD") (require "JVM") (require "COMPILER-PASS1") (require "JAVA")) @@ -145,6 +146,7 @@ (5 (emit 'iconst_5)) (t + (assert (<= most-negative-fixnum n most-positive-fixnum)) (if (<= -128 n 127) (emit 'bipush n) (if (<= -32768 n 32767) Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Mar 3 13:57:41 2013 (r14417) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Mar 3 14:02:50 2013 (r14418) @@ -467,11 +467,17 @@ (declaim (inline make-constant-float make-constant-int)) (defun make-constant-float (index value) "Creates a `constant-float/int' structure instance containing a float." - (%make-constant-float/int 4 index value)) + (%make-constant-float/int 4 index (if (minusp value) + (1+ (logxor (- value) #xFFFFFFFF)) ;; convert to unsigned + value))) (defun make-constant-int (index value) "Creates a `constant-float/int' structure instance containing an int." - (%make-constant-float/int 3 index value)) + (assert (and t (<= most-negative-fixnum value most-positive-fixnum))) + (%make-constant-float/int 3 index + (if (minusp value) + (1+ (logxor (- value) #xFFFFFFFF)) ;; convert to unsigned + value))) (defstruct (constant-double/long (:constructor %make-constant-double/long (tag index value)) @@ -828,11 +834,12 @@ (finalize-attributes (class-file-attributes class) nil class)) -(declaim (inline write-u1 write-u2 write-u4 write-s4)) +(declaim (inline write-u1 write-u2 write-u4)) (defun write-u1 (n stream) (declare (optimize speed)) (declare (type (unsigned-byte 8) n)) (declare (type stream stream)) + (assert (<= #x0 n #xFF)) (write-8-bits n stream)) (defknown write-u2 (t t) t) @@ -840,6 +847,7 @@ (declare (optimize speed)) (declare (type (unsigned-byte 16) n)) (declare (type stream stream)) + (assert (<= #x0 n #xFFFF)) (write-8-bits (logand (ash n -8) #xFF) stream) (write-8-bits (logand n #xFF) stream)) @@ -847,17 +855,10 @@ (defun write-u4 (n stream) (declare (optimize speed)) (declare (type (unsigned-byte 32) n)) + (assert (<= #x0 n #xFFFFFFFF)) (write-u2 (logand (ash n -16) #xFFFF) stream) (write-u2 (logand n #xFFFF) stream)) -(declaim (ftype (function (t t) t) write-s4)) -(defun write-s4 (n stream) - (declare (optimize speed)) - (cond ((minusp n) - (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream)) - (t - (write-u4 n stream)))) - (declaim (ftype (function (t t t) t) write-ascii)) (defun write-ascii (string length stream) (declare (type string string)) @@ -868,7 +869,6 @@ (declare (type (unsigned-byte 16) i)) (write-8-bits (char-code (char string i)) stream))) - (declaim (ftype (function (t t) t) write-utf8)) (defun write-utf8 (string stream) (declare (optimize speed)) Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Mar 3 13:57:41 2013 (r14417) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Mar 3 14:02:50 2013 (r14418) @@ -783,323 +783,4 @@ -;; BYTE CODE ANALYSIS AND OPTIMIZATION - -(declaim (ftype (function (t t t) t) analyze-stack-path)) -(defun analyze-stack-path (code start-index depth) - (declare (optimize speed)) - (declare (type fixnum start-index depth)) - (do* ((i start-index (1+ i)) - (limit (length code))) - ((>= i limit)) - (declare (type fixnum i limit)) - (let* ((instruction (aref code i)) - (instruction-depth (instruction-depth instruction)) - (instruction-stack (instruction-stack instruction))) - (declare (type fixnum instruction-stack)) - (when instruction-depth - (unless (= (the fixnum instruction-depth) - (the fixnum (+ depth instruction-stack))) - (internal-compiler-error "Stack inconsistency detected ~ - in ~A at index ~D: ~ - found ~S, expected ~S." - (if *current-compiland* - (compiland-name *current-compiland*) - "") - i instruction-depth - (+ depth instruction-stack))) - (return-from analyze-stack-path)) - (let ((opcode (instruction-opcode instruction))) - (setf depth (+ depth instruction-stack)) - (setf (instruction-depth instruction) depth) - (unless (<= 0 depth) - (internal-compiler-error "Stack inconsistency detected ~ - in ~A at index ~D: ~ - negative depth ~S." - (if *current-compiland* - (compiland-name *current-compiland*) - "") - i depth)) - (when (branch-p opcode) - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (analyze-stack-path code (symbol-value label) depth))) - (when (unconditional-control-transfer-p opcode) - ;; Current path ends. - (return-from analyze-stack-path)))))) - -(declaim (ftype (function (t) t) analyze-stack)) -(defun analyze-stack (code exception-entry-points) - (declare (optimize speed)) - (let* ((code-length (length code))) - (declare (type vector code)) - (dotimes (i code-length) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (when (eql opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label i))) - (unless (instruction-stack instruction) - (setf (instruction-stack instruction) - (opcode-stack-effect opcode)) - (unless (instruction-stack instruction) - (sys::%format t "no stack information for instruction ~D~%" - (instruction-opcode instruction)) - (aver nil))))) - (analyze-stack-path code 0 0) - (dolist (entry-point exception-entry-points) - ;; Stack depth is always 1 when handler is called. - (analyze-stack-path code (symbol-value entry-point) 1)) - (let ((max-stack 0)) - (declare (type fixnum max-stack)) - (dotimes (i code-length) - (let* ((instruction (aref code i)) - (instruction-depth (instruction-depth instruction))) - (when instruction-depth - (setf max-stack (max max-stack (the fixnum instruction-depth)))))) - max-stack))) - -(defun analyze-locals (code) - (let ((code-length (length code)) - (max-local 0)) - (dotimes (i code-length max-local) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (setf max-local - (max max-local - (or (let ((opcode-register - (jvm-opcode-register-used opcode))) - (if (eq t opcode-register) - (car (instruction-args instruction)) - opcode-register)) - 0))))))) - -(defun delete-unused-labels (code handler-labels) - (declare (optimize speed)) - (let ((code (coerce code 'vector)) - (changed nil) - (marker (gensym))) - ;; Mark the labels that are actually branched to. - (dotimes (i (length code)) - (let ((instruction (aref code i))) - (when (branch-p (instruction-opcode instruction)) - (let ((label (car (instruction-args instruction)))) - (set label marker))))) - ;; Add labels used for exception handlers. - (dolist (label handler-labels) - (set label marker)) - ;; Remove labels that are not used as branch targets. - (dotimes (i (length code)) - (let ((instruction (aref code i))) - (when (= (instruction-opcode instruction) 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (unless (eq (symbol-value label) marker) - (setf (aref code i) nil) - (setf changed t)))))) - (values (if changed (delete nil code) code) - changed))) - -(defun delete-unreachable-code (code) - ;; Look for unreachable code after GOTO. - (declare (optimize speed)) - (let* ((code (coerce code 'vector)) - (changed nil) - (after-goto/areturn nil)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (cond (after-goto/areturn - (if (= opcode 202) ; LABEL - (setf after-goto/areturn nil) - ;; Unreachable. - (progn - (setf (aref code i) nil) - (setf changed t)))) - ((unconditional-control-transfer-p opcode) - (setf after-goto/areturn t))))) - (values (if changed (delete nil code) code) - changed))) - - -(declaim (ftype (function (t) label-target-instructions) hash-labels)) -(defun label-target-instructions (code) - (let ((ht (make-hash-table :test 'eq)) - (code (coerce code 'vector)) - (pending-labels '())) - (dotimes (i (length code)) - (let ((instruction (aref code i))) - (cond ((label-p instruction) - (push (instruction-label instruction) pending-labels)) - (t - ;; Not a label. - (when pending-labels - (dolist (label pending-labels) - (setf (gethash label ht) instruction)) - (setf pending-labels nil)))))) - ht)) - -(defun optimize-jumps (code) - (declare (optimize speed)) - (let* ((code (coerce code 'vector)) - (ht (label-target-instructions code)) - (changed nil)) - (dotimes (i (length code)) - (let* ((instruction (aref code i)) - (opcode (and instruction (instruction-opcode instruction)))) - (when (and opcode (branch-p opcode)) - (let* ((target-label (car (instruction-args instruction))) - (next-instruction (gethash1 target-label ht))) - (when next-instruction - (case (instruction-opcode next-instruction) - ((167 200) ;; GOTO - (setf (instruction-args instruction) - (instruction-args next-instruction) - changed t)) - (176 ; ARETURN - (when (unconditional-control-transfer-p opcode) - (setf (instruction-opcode instruction) 176 - (instruction-args instruction) nil - changed t))))))))) - (values code changed))) - - -(defun optimize-instruction-sequences (code) - (let* ((code (coerce code 'vector)) - (changed nil)) - (dotimes (i (1- (length code))) - (let* ((this-instruction (aref code i)) - (this-opcode (and this-instruction - (instruction-opcode this-instruction))) - (labels-skipped-p nil) - (next-instruction (do ((j (1+ i) (1+ j))) - ((or (>= j (length code)) - (/= 202 ; LABEL - (instruction-opcode (aref code j)))) - (when (< j (length code)) - (aref code j))) - (setf labels-skipped-p t))) - (next-opcode (and next-instruction - (instruction-opcode next-instruction)))) - (case this-opcode - (205 ; CLEAR-VALUES - (when (eql next-opcode 205) ; CLEAR-VALUES - (setf (aref code i) nil) - (setf changed t))) - (178 ; GETSTATIC - (when (and (eql next-opcode 87) ; POP - (not labels-skipped-p)) - (setf (aref code i) nil) - (setf (aref code (1+ i)) nil) - (setf changed t))) - (176 ; ARETURN - (when (eql next-opcode 176) ; ARETURN - (setf (aref code i) nil) - (setf changed t))) - ((200 167) ; GOTO GOTO_W - (when (and (or (eql next-opcode 202) ; LABEL - (eql next-opcode 200) ; GOTO_W - (eql next-opcode 167)) ; GOTO - (eq (car (instruction-args this-instruction)) - (car (instruction-args next-instruction)))) - (setf (aref code i) nil) - (setf changed t)))))) - (values (if changed (delete nil code) code) - changed))) - -(defvar *enable-optimization* t) - -(defknown optimize-code (t t) t) -(defun optimize-code (code handler-labels pool) - (unless *enable-optimization* - (format t "optimizations are disabled~%")) - (when *enable-optimization* - (when *compiler-debug* - (format t "----- before optimization -----~%") - (print-code code pool)) - (loop - (let ((changed-p nil)) - (multiple-value-setq - (code changed-p) - (delete-unused-labels code handler-labels)) - (if changed-p - (setf code (optimize-instruction-sequences code)) - (multiple-value-setq - (code changed-p) - (optimize-instruction-sequences code))) - (if changed-p - (setf code (optimize-jumps code)) - (multiple-value-setq - (code changed-p) - (optimize-jumps code))) - (if changed-p - (setf code (delete-unreachable-code code)) - (multiple-value-setq - (code changed-p) - (delete-unreachable-code code))) - (unless changed-p - (return)))) - (unless (vectorp code) - (setf code (coerce code 'vector))) - (when *compiler-debug* - (sys::%format t "----- after optimization -----~%") - (print-code code pool))) - code) - - - - -(defun code-bytes (code) - (let ((length 0) - labels ;; alist - ) - (declare (type (unsigned-byte 16) length)) - ;; Pass 1: calculate label offsets and overall length. - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (if (= opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label length) - (setf labels - (acons label length labels))) - (incf length (opcode-size opcode))))) - ;; Pass 2: replace labels with calculated offsets. - (let ((index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (branch-p (instruction-opcode instruction)) - (let* ((label (car (instruction-args instruction))) - (offset (- (the (unsigned-byte 16) - (symbol-value (the symbol label))) - index))) - (assert (<= -32768 offset 32767)) - (setf (instruction-args instruction) (s2 offset)))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (incf index (opcode-size (instruction-opcode instruction))))))) - ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. - (let ((bytes (make-array length)) - (index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (setf (svref bytes index) (instruction-opcode instruction)) - (incf index) - (dolist (byte (instruction-args instruction)) - (setf (svref bytes index) byte) - (incf index))))) - (values bytes labels)))) - -(defun finalize-code (code handler-labels optimize pool) - (setf code (coerce (nreverse code) 'vector)) - (when optimize - (setf code (optimize-code code handler-labels pool))) - (resolve-instructions (expand-virtual-instructions code))) - (provide '#:jvm-instructions) Added: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp Sun Mar 3 14:02:50 2013 (r14418) @@ -0,0 +1,479 @@ +;;; jvm-class-file.lisp +;;; +;;; Copyright (C) 2010 Erik Huelsmann +;;; $Id: jvm-class-file.lisp 14096 2012-08-15 22:55:27Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "JVM") + +(require '#:jvm-class-file) +(require '#:jvm-instructions) + +(defvar *stack-effects* + (make-hash-table :test 'eq)) + +(defun %define-stack-effect (names lambda) + (dolist (name (if (consp names) names (list names))) + (setf (gethash name *stack-effects*) lambda))) + +(defmacro define-stack-effect (opcode args &body body) + `(%define-stack-effect ',opcode (lambda ,args , at body))) + +(define-stack-effect (nop ineg lneg fneg dneg) + (instruction stack locals pool) + (declare (ignore instruction locals pool)) + stack) + +(define-stack-effect aconst_null (instruction stack locals pool) + (declare (ignore instruction locals pool)) + (cons :null stack)) + +(define-stack-effect (iconst_m1 iconst_0 iconst_1 + iconst_2 iconst_3 + iconst_4 iconst_5 + bipush sipush + iload_0 iload_1 + iload_2 iload_3) (instruction stack locals pool) + (declare (ignore instruction locals)) + (cons :int stack)) + +(define-stack-effect iload (instruction stack locals pool) + (declare (ignore instruction locals)) + (cons :int stack)) + +(define-stack-effect (aload_0 aload_1 aload_2 aload_3) + (instruction stack locals pool) + (declare (ignore instruction locals)) + (let* ((opcode (instruction-opcode instruction))) + (cons (car (nth (ecase opcode + ;; todo? use the instruction opcode register + (aload_0 0) + (aload_1 1) + (aload_2 2) + (aload_3 3)) + locals)) + stack))) + +(define-stack-effect (istore fstore astore istore_0 istore_1 + istore_2 istore_3 fstore_0 fstore_1 fstore_2 + fstore_3 astore_1 astore_2 astore_3 pop) + (instruction stack locals pool) + (declare (ignore instruction locals)) + (cdr stack)) + +(defun apply-stack-effect (context instruction) + (let ((handler (gethash (instruction-opcode instruction) + *stack-effects*))) + (if handler + (funcall handler instruction (method-context-stack context) + (method-context-locals context) + (class-pool (method-context-class context))) + ;; (method-context-stack context) + (assert (and "no opcode defined" nil))))) + + +(defstruct (method-context (:constructor %make-method-context)) + method ;; jvm method + code ;; list of lists with the first value the instruction, + ;; the second the stack after instruction execution and + ;; the third the state of the function locals during execution + class ;; jvm class + locals ;; a list of conses: each local occupies a cons of which + ;; the CAR is the type last declared (or NIL if none) + ;; and the CDR indicates availability (NIL or :AVAILABLE) + stack ;; a list of types pushed onto the stack + ;; either a symbol, indicating a primitive type, or + ;; a JVM-CLASS-NAME structure indicating a real class + ) + +(defun make-method-context (class name return args &key (flags '(:public))) + (let ((frame (make-stack-frame-state)) + (method (make-jvm-method name return args :flags flags))) + (dolist (arg args) + (allocate-local frame arg)) + (%make-method-context :method method + :code (method-ensure-code method) + :class class + :frame-state frame))) + +(defun add-instruction (context instruction) + "Adds the instruction to the method, updating the context's stack." + (let ((stack (apply-stack-effect instruction (method-context-stack context)))) + (push (list instruction stack (method-context-locals context)) code) + (setf (method-context-stack context) stack))) + + +(defun allocate-local (context type) + (let ((allocated (find-if :available (method-context-locals context) + :key #'cdr)) + (new-value (cons type))) + (setf (method-context-locals context) + (if allocated + (substitute (cons type) allocated + (method-context-locals context)) + (append (method-context-locals context) + (list new-value)))) + new-value)) + +(defun declare-local-type (context local-number type) + (let ((local (nth local-number (method-context-locals frame)))) + (assert local) + (setf (car local) type))) + +(defun free-local (context local-number) + (let ((local (nth local-number (method-context-locals frame)))) + (assert local) + (setf (cdr local) :available))) + + + + + + + + +(declaim (ftype (function (t t t) t) analyze-stack-path)) +(defun analyze-stack-path (code start-index depth) + (declare (optimize speed)) + (declare (type fixnum start-index depth)) + (do* ((i start-index (1+ i)) + (limit (length code))) + ((>= i limit)) + (declare (type fixnum i limit)) + (let* ((instruction (aref code i)) + (instruction-depth (instruction-depth instruction)) + (instruction-stack (instruction-stack instruction))) + (declare (type fixnum instruction-stack)) + (when instruction-depth + (unless (= (the fixnum instruction-depth) + (the fixnum (+ depth instruction-stack))) + (internal-compiler-error "Stack inconsistency detected ~ + in ~A at index ~D: ~ + found ~S, expected ~S." + (if *current-compiland* + (compiland-name *current-compiland*) + "") + i instruction-depth + (+ depth instruction-stack))) + (return-from analyze-stack-path)) + (let ((opcode (instruction-opcode instruction))) + (setf depth (+ depth instruction-stack)) + (setf (instruction-depth instruction) depth) + (unless (<= 0 depth) + (internal-compiler-error "Stack inconsistency detected ~ + in ~A at index ~D: ~ + negative depth ~S." + (if *current-compiland* + (compiland-name *current-compiland*) + "") + i depth)) + (when (branch-p opcode) + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (analyze-stack-path code (symbol-value label) depth))) + (when (unconditional-control-transfer-p opcode) + ;; Current path ends. + (return-from analyze-stack-path)))))) + +(declaim (ftype (function (t) t) analyze-stack)) +(defun analyze-stack (code exception-entry-points) + (declare (optimize speed)) + (let* ((code-length (length code))) + (declare (type vector code)) + (dotimes (i code-length) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (when (eql opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label i))) + (unless (instruction-stack instruction) + (setf (instruction-stack instruction) + (opcode-stack-effect opcode)) + (unless (instruction-stack instruction) + (sys::%format t "no stack information for instruction ~D~%" + (instruction-opcode instruction)) + (aver nil))))) + (analyze-stack-path code 0 0) + (dolist (entry-point exception-entry-points) + ;; Stack depth is always 1 when handler is called. + (analyze-stack-path code (symbol-value entry-point) 1)) + (let ((max-stack 0)) + (declare (type fixnum max-stack)) + (dotimes (i code-length) + (let* ((instruction (aref code i)) + (instruction-depth (instruction-depth instruction))) + (when instruction-depth + (setf max-stack (max max-stack (the fixnum instruction-depth)))))) + max-stack))) + +;; (defun analyze-locals (code) +;; (let ((code-length (length code)) +;; (max-local 0)) +;; (dotimes (i code-length max-local) +;; (let* ((instruction (aref code i)) +;; (opcode (instruction-opcode instruction))) +;; (setf max-local +;; (max max-local +;; (or (let ((opcode-register +;; (jvm-opcode-register-used opcode))) +;; (if (eq t opcode-register) +;; (car (instruction-args instruction)) +;; opcode-register)) +;; 0))))))) + + + + +(declaim (ftype (function (t) label-target-instructions) hash-labels)) +(defun label-target-instructions (code) + (let ((ht (make-hash-table :test 'eq)) + (code (coerce code 'vector)) + (pending-labels '())) + (dotimes (i (length code)) + (let ((instruction (aref code i))) + (cond ((label-p instruction) + (push (instruction-label instruction) pending-labels)) + (t + ;; Not a label. + (when pending-labels + (dolist (label pending-labels) + (setf (gethash label ht) instruction)) + (setf pending-labels nil)))))) + ht)) + + + +(defun delete-unused-labels (code handler-labels) + (declare (optimize speed)) + (let ((code (coerce code 'vector)) + (changed nil) + (marker (gensym))) + ;; Mark the labels that are actually branched to. + (dotimes (i (length code)) + (let ((instruction (aref code i))) + (when (branch-p (instruction-opcode instruction)) + (let ((label (car (instruction-args instruction)))) + (set label marker))))) + ;; Add labels used for exception handlers. + (dolist (label handler-labels) + (set label marker)) + ;; Remove labels that are not used as branch targets. + (dotimes (i (length code)) + (let ((instruction (aref code i))) + (when (= (instruction-opcode instruction) 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (unless (eq (symbol-value label) marker) + (setf (aref code i) nil) + (setf changed t)))))) + (values (if changed (delete nil code) code) + changed))) + + +(defun optimize-instruction-sequences (code) + (let* ((code (coerce code 'vector)) + (changed nil)) + (dotimes (i (1- (length code))) + (let* ((this-instruction (aref code i)) + (this-opcode (and this-instruction + (instruction-opcode this-instruction))) + (labels-skipped-p nil) + (next-instruction (do ((j (1+ i) (1+ j))) + ((or (>= j (length code)) + (/= 202 ; LABEL + (instruction-opcode (aref code j)))) + (when (< j (length code)) + (aref code j))) + (setf labels-skipped-p t))) + (next-opcode (and next-instruction + (instruction-opcode next-instruction)))) + (case this-opcode + (205 ; CLEAR-VALUES + (when (eql next-opcode 205) ; CLEAR-VALUES + (setf (aref code i) nil) + (setf changed t))) + (178 ; GETSTATIC + (when (and (eql next-opcode 87) ; POP + (not labels-skipped-p)) + (setf (aref code i) nil) + (setf (aref code (1+ i)) nil) + (setf changed t))) + (176 ; ARETURN + (when (eql next-opcode 176) ; ARETURN + (setf (aref code i) nil) + (setf changed t))) + ((200 167) ; GOTO GOTO_W + (when (and (or (eql next-opcode 202) ; LABEL + (eql next-opcode 200) ; GOTO_W + (eql next-opcode 167)) ; GOTO + (eq (car (instruction-args this-instruction)) + (car (instruction-args next-instruction)))) + (setf (aref code i) nil) + (setf changed t)))))) + (values (if changed (delete nil code) code) + changed))) + +(defun optimize-jumps (code) + (declare (optimize speed)) + (let* ((code (coerce code 'vector)) + (ht (label-target-instructions code)) + (changed nil)) + (dotimes (i (length code)) + (let* ((instruction (aref code i)) + (opcode (and instruction (instruction-opcode instruction)))) + (when (and opcode (branch-p opcode)) + (let* ((target-label (car (instruction-args instruction))) + (next-instruction (gethash1 target-label ht))) + (when next-instruction + (case (instruction-opcode next-instruction) + ((167 200) ;; GOTO + (setf (instruction-args instruction) + (instruction-args next-instruction) + changed t)) + (176 ; ARETURN + (when (unconditional-control-transfer-p opcode) + (setf (instruction-opcode instruction) 176 + (instruction-args instruction) nil + changed t))))))))) + (values code changed))) + +(defun delete-unreachable-code (code) + ;; Look for unreachable code after GOTO. + (declare (optimize speed)) + (let* ((code (coerce code 'vector)) + (changed nil) + (after-goto/areturn nil)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (cond (after-goto/areturn + (if (= opcode 202) ; LABEL + (setf after-goto/areturn nil) + ;; Unreachable. + (progn + (setf (aref code i) nil) + (setf changed t)))) + ((unconditional-control-transfer-p opcode) + (setf after-goto/areturn t))))) + (values (if changed (delete nil code) code) + changed))) + +(defvar *enable-optimization* t) + +(defknown optimize-code (t t) t) +(defun optimize-code (code handler-labels pool) + (unless *enable-optimization* + (format t "optimizations are disabled~%")) + (when *enable-optimization* + (when *compiler-debug* + (format t "----- before optimization -----~%") + (print-code code pool)) + (loop + (let ((changed-p nil)) + (multiple-value-setq + (code changed-p) + (delete-unused-labels code handler-labels)) + (if changed-p + (setf code (optimize-instruction-sequences code)) + (multiple-value-setq + (code changed-p) + (optimize-instruction-sequences code))) + (if changed-p + (setf code (optimize-jumps code)) + (multiple-value-setq + (code changed-p) + (optimize-jumps code))) + (if changed-p + (setf code (delete-unreachable-code code)) + (multiple-value-setq + (code changed-p) + (delete-unreachable-code code))) + (unless changed-p + (return)))) + (unless (vectorp code) + (setf code (coerce code 'vector))) + (when *compiler-debug* + (sys::%format t "----- after optimization -----~%") + (print-code code pool))) + code) + +(defun code-bytes (code) + (let ((length 0) + labels ;; alist + ) + (declare (type (unsigned-byte 16) length)) + ;; Pass 1: calculate label offsets and overall length. + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (if (= opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label length) + (setf labels + (acons label length labels))) + (incf length (opcode-size opcode))))) + ;; Pass 2: replace labels with calculated offsets. + (let ((index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (branch-p (instruction-opcode instruction)) + (let* ((label (car (instruction-args instruction))) + (offset (- (the (unsigned-byte 16) + (symbol-value (the symbol label))) + index))) + (assert (<= -32768 offset 32767)) + (setf (instruction-args instruction) (s2 offset)))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (incf index (opcode-size (instruction-opcode instruction))))))) + ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. + (let ((bytes (make-array length)) + (index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (setf (svref bytes index) (instruction-opcode instruction)) + (incf index) + (dolist (byte (instruction-args instruction)) + (setf (svref bytes index) byte) + (incf index))))) + (values bytes labels)))) + +(defun finalize-code (code handler-labels optimize pool) + (setf code (coerce (nreverse code) 'vector)) + (when optimize + (setf code (optimize-code code handler-labels pool))) + (resolve-instructions (expand-virtual-instructions code))) + + +(provide '#:jvm-method) \ No newline at end of file From ehuelsmann at common-lisp.net Sun Mar 3 22:06:27 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 03 Mar 2013 14:06:27 -0800 Subject: [armedbear-cvs] r14419 - branches/typed-asm/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 3 14:06:26 2013 New Revision: 14419 Log: Add required properties and correct header. Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp (contents, props changed) Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp ============================================================================== --- branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp Sun Mar 3 14:02:50 2013 (r14418) +++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp Sun Mar 3 14:06:26 2013 (r14419) @@ -1,479 +1,479 @@ -;;; jvm-class-file.lisp -;;; -;;; Copyright (C) 2010 Erik Huelsmann -;;; $Id: jvm-class-file.lisp 14096 2012-08-15 22:55:27Z ehuelsmann $ -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License -;;; as published by the Free Software Foundation; either version 2 -;;; of the License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -;;; -;;; As a special exception, the copyright holders of this library give you -;;; permission to link this library with independent modules to produce an -;;; executable, regardless of the license terms of these independent -;;; modules, and to copy and distribute the resulting executable under -;;; terms of your choice, provided that you also meet, for each linked -;;; independent module, the terms and conditions of the license of that -;;; module. An independent module is a module which is not derived from -;;; or based on this library. If you modify this library, you may extend -;;; this exception to your version of the library, but you are not -;;; obligated to do so. If you do not wish to do so, delete this -;;; exception statement from your version. - -(in-package "JVM") - -(require '#:jvm-class-file) -(require '#:jvm-instructions) - -(defvar *stack-effects* - (make-hash-table :test 'eq)) - -(defun %define-stack-effect (names lambda) - (dolist (name (if (consp names) names (list names))) - (setf (gethash name *stack-effects*) lambda))) - -(defmacro define-stack-effect (opcode args &body body) - `(%define-stack-effect ',opcode (lambda ,args , at body))) - -(define-stack-effect (nop ineg lneg fneg dneg) - (instruction stack locals pool) - (declare (ignore instruction locals pool)) - stack) - -(define-stack-effect aconst_null (instruction stack locals pool) - (declare (ignore instruction locals pool)) - (cons :null stack)) - -(define-stack-effect (iconst_m1 iconst_0 iconst_1 - iconst_2 iconst_3 - iconst_4 iconst_5 - bipush sipush - iload_0 iload_1 - iload_2 iload_3) (instruction stack locals pool) - (declare (ignore instruction locals)) - (cons :int stack)) - -(define-stack-effect iload (instruction stack locals pool) - (declare (ignore instruction locals)) - (cons :int stack)) - -(define-stack-effect (aload_0 aload_1 aload_2 aload_3) - (instruction stack locals pool) - (declare (ignore instruction locals)) - (let* ((opcode (instruction-opcode instruction))) - (cons (car (nth (ecase opcode - ;; todo? use the instruction opcode register - (aload_0 0) - (aload_1 1) - (aload_2 2) - (aload_3 3)) - locals)) - stack))) - -(define-stack-effect (istore fstore astore istore_0 istore_1 - istore_2 istore_3 fstore_0 fstore_1 fstore_2 - fstore_3 astore_1 astore_2 astore_3 pop) - (instruction stack locals pool) - (declare (ignore instruction locals)) - (cdr stack)) - -(defun apply-stack-effect (context instruction) - (let ((handler (gethash (instruction-opcode instruction) - *stack-effects*))) - (if handler - (funcall handler instruction (method-context-stack context) - (method-context-locals context) - (class-pool (method-context-class context))) - ;; (method-context-stack context) - (assert (and "no opcode defined" nil))))) - - -(defstruct (method-context (:constructor %make-method-context)) - method ;; jvm method - code ;; list of lists with the first value the instruction, - ;; the second the stack after instruction execution and - ;; the third the state of the function locals during execution - class ;; jvm class - locals ;; a list of conses: each local occupies a cons of which - ;; the CAR is the type last declared (or NIL if none) - ;; and the CDR indicates availability (NIL or :AVAILABLE) - stack ;; a list of types pushed onto the stack - ;; either a symbol, indicating a primitive type, or - ;; a JVM-CLASS-NAME structure indicating a real class - ) - -(defun make-method-context (class name return args &key (flags '(:public))) - (let ((frame (make-stack-frame-state)) - (method (make-jvm-method name return args :flags flags))) - (dolist (arg args) - (allocate-local frame arg)) - (%make-method-context :method method - :code (method-ensure-code method) - :class class - :frame-state frame))) - -(defun add-instruction (context instruction) - "Adds the instruction to the method, updating the context's stack." - (let ((stack (apply-stack-effect instruction (method-context-stack context)))) - (push (list instruction stack (method-context-locals context)) code) - (setf (method-context-stack context) stack))) - - -(defun allocate-local (context type) - (let ((allocated (find-if :available (method-context-locals context) - :key #'cdr)) - (new-value (cons type))) - (setf (method-context-locals context) - (if allocated - (substitute (cons type) allocated - (method-context-locals context)) - (append (method-context-locals context) - (list new-value)))) - new-value)) - -(defun declare-local-type (context local-number type) - (let ((local (nth local-number (method-context-locals frame)))) - (assert local) - (setf (car local) type))) - -(defun free-local (context local-number) - (let ((local (nth local-number (method-context-locals frame)))) - (assert local) - (setf (cdr local) :available))) - - - - - - - - -(declaim (ftype (function (t t t) t) analyze-stack-path)) -(defun analyze-stack-path (code start-index depth) - (declare (optimize speed)) - (declare (type fixnum start-index depth)) - (do* ((i start-index (1+ i)) - (limit (length code))) - ((>= i limit)) - (declare (type fixnum i limit)) - (let* ((instruction (aref code i)) - (instruction-depth (instruction-depth instruction)) - (instruction-stack (instruction-stack instruction))) - (declare (type fixnum instruction-stack)) - (when instruction-depth - (unless (= (the fixnum instruction-depth) - (the fixnum (+ depth instruction-stack))) - (internal-compiler-error "Stack inconsistency detected ~ - in ~A at index ~D: ~ - found ~S, expected ~S." - (if *current-compiland* - (compiland-name *current-compiland*) - "") - i instruction-depth - (+ depth instruction-stack))) - (return-from analyze-stack-path)) - (let ((opcode (instruction-opcode instruction))) - (setf depth (+ depth instruction-stack)) - (setf (instruction-depth instruction) depth) - (unless (<= 0 depth) - (internal-compiler-error "Stack inconsistency detected ~ - in ~A at index ~D: ~ - negative depth ~S." - (if *current-compiland* - (compiland-name *current-compiland*) - "") - i depth)) - (when (branch-p opcode) - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (analyze-stack-path code (symbol-value label) depth))) - (when (unconditional-control-transfer-p opcode) - ;; Current path ends. - (return-from analyze-stack-path)))))) - -(declaim (ftype (function (t) t) analyze-stack)) -(defun analyze-stack (code exception-entry-points) - (declare (optimize speed)) - (let* ((code-length (length code))) - (declare (type vector code)) - (dotimes (i code-length) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (when (eql opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label i))) - (unless (instruction-stack instruction) - (setf (instruction-stack instruction) - (opcode-stack-effect opcode)) - (unless (instruction-stack instruction) - (sys::%format t "no stack information for instruction ~D~%" - (instruction-opcode instruction)) - (aver nil))))) - (analyze-stack-path code 0 0) - (dolist (entry-point exception-entry-points) - ;; Stack depth is always 1 when handler is called. - (analyze-stack-path code (symbol-value entry-point) 1)) - (let ((max-stack 0)) - (declare (type fixnum max-stack)) - (dotimes (i code-length) - (let* ((instruction (aref code i)) - (instruction-depth (instruction-depth instruction))) - (when instruction-depth - (setf max-stack (max max-stack (the fixnum instruction-depth)))))) - max-stack))) - -;; (defun analyze-locals (code) -;; (let ((code-length (length code)) -;; (max-local 0)) -;; (dotimes (i code-length max-local) -;; (let* ((instruction (aref code i)) -;; (opcode (instruction-opcode instruction))) -;; (setf max-local -;; (max max-local -;; (or (let ((opcode-register -;; (jvm-opcode-register-used opcode))) -;; (if (eq t opcode-register) -;; (car (instruction-args instruction)) -;; opcode-register)) -;; 0))))))) - - - - -(declaim (ftype (function (t) label-target-instructions) hash-labels)) -(defun label-target-instructions (code) - (let ((ht (make-hash-table :test 'eq)) - (code (coerce code 'vector)) - (pending-labels '())) - (dotimes (i (length code)) - (let ((instruction (aref code i))) - (cond ((label-p instruction) - (push (instruction-label instruction) pending-labels)) - (t - ;; Not a label. - (when pending-labels - (dolist (label pending-labels) - (setf (gethash label ht) instruction)) - (setf pending-labels nil)))))) - ht)) - - - -(defun delete-unused-labels (code handler-labels) - (declare (optimize speed)) - (let ((code (coerce code 'vector)) - (changed nil) - (marker (gensym))) - ;; Mark the labels that are actually branched to. - (dotimes (i (length code)) - (let ((instruction (aref code i))) - (when (branch-p (instruction-opcode instruction)) - (let ((label (car (instruction-args instruction)))) - (set label marker))))) - ;; Add labels used for exception handlers. - (dolist (label handler-labels) - (set label marker)) - ;; Remove labels that are not used as branch targets. - (dotimes (i (length code)) - (let ((instruction (aref code i))) - (when (= (instruction-opcode instruction) 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (unless (eq (symbol-value label) marker) - (setf (aref code i) nil) - (setf changed t)))))) - (values (if changed (delete nil code) code) - changed))) - - -(defun optimize-instruction-sequences (code) - (let* ((code (coerce code 'vector)) - (changed nil)) - (dotimes (i (1- (length code))) - (let* ((this-instruction (aref code i)) - (this-opcode (and this-instruction - (instruction-opcode this-instruction))) - (labels-skipped-p nil) - (next-instruction (do ((j (1+ i) (1+ j))) - ((or (>= j (length code)) - (/= 202 ; LABEL - (instruction-opcode (aref code j)))) - (when (< j (length code)) - (aref code j))) - (setf labels-skipped-p t))) - (next-opcode (and next-instruction - (instruction-opcode next-instruction)))) - (case this-opcode - (205 ; CLEAR-VALUES - (when (eql next-opcode 205) ; CLEAR-VALUES - (setf (aref code i) nil) - (setf changed t))) - (178 ; GETSTATIC - (when (and (eql next-opcode 87) ; POP - (not labels-skipped-p)) - (setf (aref code i) nil) - (setf (aref code (1+ i)) nil) - (setf changed t))) - (176 ; ARETURN - (when (eql next-opcode 176) ; ARETURN - (setf (aref code i) nil) - (setf changed t))) - ((200 167) ; GOTO GOTO_W - (when (and (or (eql next-opcode 202) ; LABEL - (eql next-opcode 200) ; GOTO_W - (eql next-opcode 167)) ; GOTO - (eq (car (instruction-args this-instruction)) - (car (instruction-args next-instruction)))) - (setf (aref code i) nil) - (setf changed t)))))) - (values (if changed (delete nil code) code) - changed))) - -(defun optimize-jumps (code) - (declare (optimize speed)) - (let* ((code (coerce code 'vector)) - (ht (label-target-instructions code)) - (changed nil)) - (dotimes (i (length code)) - (let* ((instruction (aref code i)) - (opcode (and instruction (instruction-opcode instruction)))) - (when (and opcode (branch-p opcode)) - (let* ((target-label (car (instruction-args instruction))) - (next-instruction (gethash1 target-label ht))) - (when next-instruction - (case (instruction-opcode next-instruction) - ((167 200) ;; GOTO - (setf (instruction-args instruction) - (instruction-args next-instruction) - changed t)) - (176 ; ARETURN - (when (unconditional-control-transfer-p opcode) - (setf (instruction-opcode instruction) 176 - (instruction-args instruction) nil - changed t))))))))) - (values code changed))) - -(defun delete-unreachable-code (code) - ;; Look for unreachable code after GOTO. - (declare (optimize speed)) - (let* ((code (coerce code 'vector)) - (changed nil) - (after-goto/areturn nil)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (cond (after-goto/areturn - (if (= opcode 202) ; LABEL - (setf after-goto/areturn nil) - ;; Unreachable. - (progn - (setf (aref code i) nil) - (setf changed t)))) - ((unconditional-control-transfer-p opcode) - (setf after-goto/areturn t))))) - (values (if changed (delete nil code) code) - changed))) - -(defvar *enable-optimization* t) - -(defknown optimize-code (t t) t) -(defun optimize-code (code handler-labels pool) - (unless *enable-optimization* - (format t "optimizations are disabled~%")) - (when *enable-optimization* - (when *compiler-debug* - (format t "----- before optimization -----~%") - (print-code code pool)) - (loop - (let ((changed-p nil)) - (multiple-value-setq - (code changed-p) - (delete-unused-labels code handler-labels)) - (if changed-p - (setf code (optimize-instruction-sequences code)) - (multiple-value-setq - (code changed-p) - (optimize-instruction-sequences code))) - (if changed-p - (setf code (optimize-jumps code)) - (multiple-value-setq - (code changed-p) - (optimize-jumps code))) - (if changed-p - (setf code (delete-unreachable-code code)) - (multiple-value-setq - (code changed-p) - (delete-unreachable-code code))) - (unless changed-p - (return)))) - (unless (vectorp code) - (setf code (coerce code 'vector))) - (when *compiler-debug* - (sys::%format t "----- after optimization -----~%") - (print-code code pool))) - code) - -(defun code-bytes (code) - (let ((length 0) - labels ;; alist - ) - (declare (type (unsigned-byte 16) length)) - ;; Pass 1: calculate label offsets and overall length. - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (if (= opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label length) - (setf labels - (acons label length labels))) - (incf length (opcode-size opcode))))) - ;; Pass 2: replace labels with calculated offsets. - (let ((index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (branch-p (instruction-opcode instruction)) - (let* ((label (car (instruction-args instruction))) - (offset (- (the (unsigned-byte 16) - (symbol-value (the symbol label))) - index))) - (assert (<= -32768 offset 32767)) - (setf (instruction-args instruction) (s2 offset)))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (incf index (opcode-size (instruction-opcode instruction))))))) - ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. - (let ((bytes (make-array length)) - (index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (setf (svref bytes index) (instruction-opcode instruction)) - (incf index) - (dolist (byte (instruction-args instruction)) - (setf (svref bytes index) byte) - (incf index))))) - (values bytes labels)))) - -(defun finalize-code (code handler-labels optimize pool) - (setf code (coerce (nreverse code) 'vector)) - (when optimize - (setf code (optimize-code code handler-labels pool))) - (resolve-instructions (expand-virtual-instructions code))) - - +;;; jvm-method.lisp +;;; +;;; Copyright (C) 2010 Erik Huelsmann +;;; $Id$ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "JVM") + +(require '#:jvm-class-file) +(require '#:jvm-instructions) + +(defvar *stack-effects* + (make-hash-table :test 'eq)) + +(defun %define-stack-effect (names lambda) + (dolist (name (if (consp names) names (list names))) + (setf (gethash name *stack-effects*) lambda))) + +(defmacro define-stack-effect (opcode args &body body) + `(%define-stack-effect ',opcode (lambda ,args , at body))) + +(define-stack-effect (nop ineg lneg fneg dneg) + (instruction stack locals pool) + (declare (ignore instruction locals pool)) + stack) + +(define-stack-effect aconst_null (instruction stack locals pool) + (declare (ignore instruction locals pool)) + (cons :null stack)) + +(define-stack-effect (iconst_m1 iconst_0 iconst_1 + iconst_2 iconst_3 + iconst_4 iconst_5 + bipush sipush + iload_0 iload_1 + iload_2 iload_3) (instruction stack locals pool) + (declare (ignore instruction locals)) + (cons :int stack)) + +(define-stack-effect iload (instruction stack locals pool) + (declare (ignore instruction locals)) + (cons :int stack)) + +(define-stack-effect (aload_0 aload_1 aload_2 aload_3) + (instruction stack locals pool) + (declare (ignore instruction locals)) + (let* ((opcode (instruction-opcode instruction))) + (cons (car (nth (ecase opcode + ;; todo? use the instruction opcode register + (aload_0 0) + (aload_1 1) + (aload_2 2) + (aload_3 3)) + locals)) + stack))) + +(define-stack-effect (istore fstore astore istore_0 istore_1 + istore_2 istore_3 fstore_0 fstore_1 fstore_2 + fstore_3 astore_1 astore_2 astore_3 pop) + (instruction stack locals pool) + (declare (ignore instruction locals)) + (cdr stack)) + +(defun apply-stack-effect (context instruction) + (let ((handler (gethash (instruction-opcode instruction) + *stack-effects*))) + (if handler + (funcall handler instruction (method-context-stack context) + (method-context-locals context) + (class-pool (method-context-class context))) + ;; (method-context-stack context) + (assert (and "no opcode defined" nil))))) + + +(defstruct (method-context (:constructor %make-method-context)) + method ;; jvm method + code ;; list of lists with the first value the instruction, + ;; the second the stack after instruction execution and + ;; the third the state of the function locals during execution + class ;; jvm class + locals ;; a list of conses: each local occupies a cons of which + ;; the CAR is the type last declared (or NIL if none) + ;; and the CDR indicates availability (NIL or :AVAILABLE) + stack ;; a list of types pushed onto the stack + ;; either a symbol, indicating a primitive type, or + ;; a JVM-CLASS-NAME structure indicating a real class + ) + +(defun make-method-context (class name return args &key (flags '(:public))) + (let ((frame (make-stack-frame-state)) + (method (make-jvm-method name return args :flags flags))) + (dolist (arg args) + (allocate-local frame arg)) + (%make-method-context :method method + :code (method-ensure-code method) + :class class + :frame-state frame))) + +(defun add-instruction (context instruction) + "Adds the instruction to the method, updating the context's stack." + (let ((stack (apply-stack-effect instruction (method-context-stack context)))) + (push (list instruction stack (method-context-locals context)) code) + (setf (method-context-stack context) stack))) + + +(defun allocate-local (context type) + (let ((allocated (find-if :available (method-context-locals context) + :key #'cdr)) + (new-value (cons type))) + (setf (method-context-locals context) + (if allocated + (substitute (cons type) allocated + (method-context-locals context)) + (append (method-context-locals context) + (list new-value)))) + new-value)) + +(defun declare-local-type (context local-number type) + (let ((local (nth local-number (method-context-locals frame)))) + (assert local) + (setf (car local) type))) + +(defun free-local (context local-number) + (let ((local (nth local-number (method-context-locals frame)))) + (assert local) + (setf (cdr local) :available))) + + + + + + + + +(declaim (ftype (function (t t t) t) analyze-stack-path)) +(defun analyze-stack-path (code start-index depth) + (declare (optimize speed)) + (declare (type fixnum start-index depth)) + (do* ((i start-index (1+ i)) + (limit (length code))) + ((>= i limit)) + (declare (type fixnum i limit)) + (let* ((instruction (aref code i)) + (instruction-depth (instruction-depth instruction)) + (instruction-stack (instruction-stack instruction))) + (declare (type fixnum instruction-stack)) + (when instruction-depth + (unless (= (the fixnum instruction-depth) + (the fixnum (+ depth instruction-stack))) + (internal-compiler-error "Stack inconsistency detected ~ + in ~A at index ~D: ~ + found ~S, expected ~S." + (if *current-compiland* + (compiland-name *current-compiland*) + "") + i instruction-depth + (+ depth instruction-stack))) + (return-from analyze-stack-path)) + (let ((opcode (instruction-opcode instruction))) + (setf depth (+ depth instruction-stack)) + (setf (instruction-depth instruction) depth) + (unless (<= 0 depth) + (internal-compiler-error "Stack inconsistency detected ~ + in ~A at index ~D: ~ + negative depth ~S." + (if *current-compiland* + (compiland-name *current-compiland*) + "") + i depth)) + (when (branch-p opcode) + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (analyze-stack-path code (symbol-value label) depth))) + (when (unconditional-control-transfer-p opcode) + ;; Current path ends. + (return-from analyze-stack-path)))))) + +(declaim (ftype (function (t) t) analyze-stack)) +(defun analyze-stack (code exception-entry-points) + (declare (optimize speed)) + (let* ((code-length (length code))) + (declare (type vector code)) + (dotimes (i code-length) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (when (eql opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label i))) + (unless (instruction-stack instruction) + (setf (instruction-stack instruction) + (opcode-stack-effect opcode)) + (unless (instruction-stack instruction) + (sys::%format t "no stack information for instruction ~D~%" + (instruction-opcode instruction)) + (aver nil))))) + (analyze-stack-path code 0 0) + (dolist (entry-point exception-entry-points) + ;; Stack depth is always 1 when handler is called. + (analyze-stack-path code (symbol-value entry-point) 1)) + (let ((max-stack 0)) + (declare (type fixnum max-stack)) + (dotimes (i code-length) + (let* ((instruction (aref code i)) + (instruction-depth (instruction-depth instruction))) + (when instruction-depth + (setf max-stack (max max-stack (the fixnum instruction-depth)))))) + max-stack))) + +;; (defun analyze-locals (code) +;; (let ((code-length (length code)) +;; (max-local 0)) +;; (dotimes (i code-length max-local) +;; (let* ((instruction (aref code i)) +;; (opcode (instruction-opcode instruction))) +;; (setf max-local +;; (max max-local +;; (or (let ((opcode-register +;; (jvm-opcode-register-used opcode))) +;; (if (eq t opcode-register) +;; (car (instruction-args instruction)) +;; opcode-register)) +;; 0))))))) + + + + +(declaim (ftype (function (t) label-target-instructions) hash-labels)) +(defun label-target-instructions (code) + (let ((ht (make-hash-table :test 'eq)) + (code (coerce code 'vector)) + (pending-labels '())) + (dotimes (i (length code)) + (let ((instruction (aref code i))) + (cond ((label-p instruction) + (push (instruction-label instruction) pending-labels)) + (t + ;; Not a label. + (when pending-labels + (dolist (label pending-labels) + (setf (gethash label ht) instruction)) + (setf pending-labels nil)))))) + ht)) + + + +(defun delete-unused-labels (code handler-labels) + (declare (optimize speed)) + (let ((code (coerce code 'vector)) + (changed nil) + (marker (gensym))) + ;; Mark the labels that are actually branched to. + (dotimes (i (length code)) + (let ((instruction (aref code i))) + (when (branch-p (instruction-opcode instruction)) + (let ((label (car (instruction-args instruction)))) + (set label marker))))) + ;; Add labels used for exception handlers. + (dolist (label handler-labels) + (set label marker)) + ;; Remove labels that are not used as branch targets. + (dotimes (i (length code)) + (let ((instruction (aref code i))) + (when (= (instruction-opcode instruction) 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (unless (eq (symbol-value label) marker) + (setf (aref code i) nil) + (setf changed t)))))) + (values (if changed (delete nil code) code) + changed))) + + +(defun optimize-instruction-sequences (code) + (let* ((code (coerce code 'vector)) + (changed nil)) + (dotimes (i (1- (length code))) + (let* ((this-instruction (aref code i)) + (this-opcode (and this-instruction + (instruction-opcode this-instruction))) + (labels-skipped-p nil) + (next-instruction (do ((j (1+ i) (1+ j))) + ((or (>= j (length code)) + (/= 202 ; LABEL + (instruction-opcode (aref code j)))) + (when (< j (length code)) + (aref code j))) + (setf labels-skipped-p t))) + (next-opcode (and next-instruction + (instruction-opcode next-instruction)))) + (case this-opcode + (205 ; CLEAR-VALUES + (when (eql next-opcode 205) ; CLEAR-VALUES + (setf (aref code i) nil) + (setf changed t))) + (178 ; GETSTATIC + (when (and (eql next-opcode 87) ; POP + (not labels-skipped-p)) + (setf (aref code i) nil) + (setf (aref code (1+ i)) nil) + (setf changed t))) + (176 ; ARETURN + (when (eql next-opcode 176) ; ARETURN + (setf (aref code i) nil) + (setf changed t))) + ((200 167) ; GOTO GOTO_W + (when (and (or (eql next-opcode 202) ; LABEL + (eql next-opcode 200) ; GOTO_W + (eql next-opcode 167)) ; GOTO + (eq (car (instruction-args this-instruction)) + (car (instruction-args next-instruction)))) + (setf (aref code i) nil) + (setf changed t)))))) + (values (if changed (delete nil code) code) + changed))) + +(defun optimize-jumps (code) + (declare (optimize speed)) + (let* ((code (coerce code 'vector)) + (ht (label-target-instructions code)) + (changed nil)) + (dotimes (i (length code)) + (let* ((instruction (aref code i)) + (opcode (and instruction (instruction-opcode instruction)))) + (when (and opcode (branch-p opcode)) + (let* ((target-label (car (instruction-args instruction))) + (next-instruction (gethash1 target-label ht))) + (when next-instruction + (case (instruction-opcode next-instruction) + ((167 200) ;; GOTO + (setf (instruction-args instruction) + (instruction-args next-instruction) + changed t)) + (176 ; ARETURN + (when (unconditional-control-transfer-p opcode) + (setf (instruction-opcode instruction) 176 + (instruction-args instruction) nil + changed t))))))))) + (values code changed))) + +(defun delete-unreachable-code (code) + ;; Look for unreachable code after GOTO. + (declare (optimize speed)) + (let* ((code (coerce code 'vector)) + (changed nil) + (after-goto/areturn nil)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (cond (after-goto/areturn + (if (= opcode 202) ; LABEL + (setf after-goto/areturn nil) + ;; Unreachable. + (progn + (setf (aref code i) nil) + (setf changed t)))) + ((unconditional-control-transfer-p opcode) + (setf after-goto/areturn t))))) + (values (if changed (delete nil code) code) + changed))) + +(defvar *enable-optimization* t) + +(defknown optimize-code (t t) t) +(defun optimize-code (code handler-labels pool) + (unless *enable-optimization* + (format t "optimizations are disabled~%")) + (when *enable-optimization* + (when *compiler-debug* + (format t "----- before optimization -----~%") + (print-code code pool)) + (loop + (let ((changed-p nil)) + (multiple-value-setq + (code changed-p) + (delete-unused-labels code handler-labels)) + (if changed-p + (setf code (optimize-instruction-sequences code)) + (multiple-value-setq + (code changed-p) + (optimize-instruction-sequences code))) + (if changed-p + (setf code (optimize-jumps code)) + (multiple-value-setq + (code changed-p) + (optimize-jumps code))) + (if changed-p + (setf code (delete-unreachable-code code)) + (multiple-value-setq + (code changed-p) + (delete-unreachable-code code))) + (unless changed-p + (return)))) + (unless (vectorp code) + (setf code (coerce code 'vector))) + (when *compiler-debug* + (sys::%format t "----- after optimization -----~%") + (print-code code pool))) + code) + +(defun code-bytes (code) + (let ((length 0) + labels ;; alist + ) + (declare (type (unsigned-byte 16) length)) + ;; Pass 1: calculate label offsets and overall length. + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (if (= opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label length) + (setf labels + (acons label length labels))) + (incf length (opcode-size opcode))))) + ;; Pass 2: replace labels with calculated offsets. + (let ((index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (branch-p (instruction-opcode instruction)) + (let* ((label (car (instruction-args instruction))) + (offset (- (the (unsigned-byte 16) + (symbol-value (the symbol label))) + index))) + (assert (<= -32768 offset 32767)) + (setf (instruction-args instruction) (s2 offset)))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (incf index (opcode-size (instruction-opcode instruction))))))) + ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. + (let ((bytes (make-array length)) + (index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (setf (svref bytes index) (instruction-opcode instruction)) + (incf index) + (dolist (byte (instruction-args instruction)) + (setf (svref bytes index) byte) + (incf index))))) + (values bytes labels)))) + +(defun finalize-code (code handler-labels optimize pool) + (setf code (coerce (nreverse code) 'vector)) + (when optimize + (setf code (optimize-code code handler-labels pool))) + (resolve-instructions (expand-virtual-instructions code))) + + (provide '#:jvm-method) \ No newline at end of file From ehuelsmann at common-lisp.net Mon Mar 4 23:05:26 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 04 Mar 2013 15:05:26 -0800 Subject: [armedbear-cvs] r14420 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Mar 4 15:05:12 2013 New Revision: 14420 Log: Fix #308: Compiled FLET exhausts the stack. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 3 14:06:26 2013 (r14419) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Mar 4 15:05:12 2013 (r14420) @@ -2122,7 +2122,9 @@ (format t "; full call to ~S~%" op))))) (when (or (<= *speed* *debug*) *require-stack-frame*) (emit-push-current-thread)) - (cond ((eq op (compiland-name *current-compiland*)) ; recursive call + (cond ((and (eq op (compiland-name *current-compiland*)) + (null (compiland-parent *current-compiland*))) + ; recursive call (if (notinline-p op) (emit-load-externalized-object op) (aload 0))) From rschlatte at common-lisp.net Tue Mar 5 19:57:44 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 05 Mar 2013 11:57:44 -0800 Subject: [armedbear-cvs] r14421 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Mar 5 11:57:43 2013 New Revision: 14421 Log: Fix package-local nicknames - avoid failure when package has no global nicknames - in defpackage, disallow introducing CL as a nickname, not introducing a nickname for CL Modified: trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Mon Mar 4 15:05:12 2013 (r14420) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Tue Mar 5 11:57:43 2013 (r14421) @@ -778,7 +778,8 @@ return error(new LispError("Trying to define a local nickname for " + name)); } - if (name.equals(this.name) || nicknames.contains(name)) { + if (name.equals(this.name) + || (nicknames != null && nicknames.contains(name))) { return error(new LispError("Trying to override package name or nickname with a local nickname " + name)); } Modified: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Mon Mar 4 15:05:12 2013 (r14420) +++ trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Tue Mar 5 11:57:43 2013 (r14421) @@ -131,7 +131,7 @@ nickdecl)) (let ((nickname (string (first nickdecl))) (package-name (designated-package-name (second nickdecl)))) - (when (member package-name '("CL" "COMMON-LISP" "KEYWORD") + (when (member nickname '("CL" "COMMON-LISP" "KEYWORD") :test #'string-equal) (cerror "Continue anyway" (format nil "Trying to define a local nickname for package ~A" From rschlatte at common-lisp.net Tue Mar 5 20:45:12 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 05 Mar 2013 12:45:12 -0800 Subject: [armedbear-cvs] r14422 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Mar 5 12:45:10 2013 New Revision: 14422 Log: Consider package-local nicknames in printer. - Fixes #309 Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Mar 5 11:57:43 2013 (r14421) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Mar 5 12:45:10 2013 (r14422) @@ -466,106 +466,95 @@ final LispObject readtableCase = ((Readtable)CURRENT_READTABLE.symbolValue(thread)).getReadtableCase(); boolean printReadably = (PRINT_READABLY.symbolValue(thread) != NIL); - if (printReadably) - { - if (readtableCase != Keyword.UPCASE || - printCase != Keyword.UPCASE) - { - StringBuilder sb = new StringBuilder(); - if (pkg == PACKAGE_KEYWORD) - { - sb.append(':'); - } - else if (pkg instanceof Package) - { - sb.append(multipleEscape(((Package)pkg).getName())); - sb.append("::"); - } - else - { - sb.append("#:"); - } - sb.append(multipleEscape(n)); - return sb.toString(); - } - else - printEscape = true; + + if (printReadably) { + if (readtableCase != Keyword.UPCASE || printCase != Keyword.UPCASE) { + StringBuilder sb = new StringBuilder(); + if (pkg == PACKAGE_KEYWORD) { + sb.append(':'); + } else if (pkg instanceof Package) { + sb.append(multipleEscape(((Package)pkg).getName())); + sb.append("::"); + } else { + sb.append("#:"); + } + sb.append(multipleEscape(n)); + return sb.toString(); } - if (!printEscape) - { - if (pkg == PACKAGE_KEYWORD) - { - if (printCase == Keyword.DOWNCASE) - return n.toLowerCase(); - if (printCase == Keyword.CAPITALIZE) - return capitalize(n, readtableCase); - return n; - } - // Printer escaping is disabled. - if (readtableCase == Keyword.UPCASE) - { - if (printCase == Keyword.DOWNCASE) - return n.toLowerCase(); - if (printCase == Keyword.CAPITALIZE) - return capitalize(n, readtableCase); - return n; - } - else if (readtableCase == Keyword.DOWNCASE) - { - // "When the readtable case is :DOWNCASE, uppercase characters - // are printed in their own case, and lowercase characters are - // printed in the case specified by *PRINT-CASE*." (22.1.3.3.2) - if (printCase == Keyword.DOWNCASE) - return n; - if (printCase == Keyword.UPCASE) - return n.toUpperCase(); - if (printCase == Keyword.CAPITALIZE) - return capitalize(n, readtableCase); - return n; - } - else if (readtableCase == Keyword.PRESERVE) - { - return n; - } - else // INVERT - return invert(n); + else { + printEscape = true; } + } + if (!printEscape) { + if (pkg == PACKAGE_KEYWORD) { + if (printCase == Keyword.DOWNCASE) + return n.toLowerCase(); + if (printCase == Keyword.CAPITALIZE) + return capitalize(n, readtableCase); + return n; + } + // Printer escaping is disabled. + if (readtableCase == Keyword.UPCASE) { + if (printCase == Keyword.DOWNCASE) + return n.toLowerCase(); + if (printCase == Keyword.CAPITALIZE) + return capitalize(n, readtableCase); + return n; + } else if (readtableCase == Keyword.DOWNCASE) { + // "When the readtable case is :DOWNCASE, uppercase characters + // are printed in their own case, and lowercase characters are + // printed in the case specified by *PRINT-CASE*." (22.1.3.3.2) + if (printCase == Keyword.DOWNCASE) + return n; + if (printCase == Keyword.UPCASE) + return n.toUpperCase(); + if (printCase == Keyword.CAPITALIZE) + return capitalize(n, readtableCase); + return n; + } else if (readtableCase == Keyword.PRESERVE) { + return n; + } else // INVERT + return invert(n); + } // Printer escaping is enabled. final boolean escapeSymbolName = needsEscape(n, readtableCase, thread); String symbolName = escapeSymbolName ? multipleEscape(n) : n; - if (!escapeSymbolName) - { - if (readtableCase == Keyword.PRESERVE) { } - else if (readtableCase == Keyword.INVERT) - symbolName = invert(symbolName); - else if (printCase == Keyword.DOWNCASE) - symbolName = symbolName.toLowerCase(); - else if (printCase == Keyword.UPCASE) - symbolName = symbolName.toUpperCase(); - else if (printCase == Keyword.CAPITALIZE) + if (!escapeSymbolName) { + if (readtableCase == Keyword.PRESERVE) { + // nothing to do + } else if (readtableCase == Keyword.INVERT) { + symbolName = invert(symbolName); + } else if (printCase == Keyword.DOWNCASE) { + symbolName = symbolName.toLowerCase(); + } else if (printCase == Keyword.UPCASE) { + symbolName = symbolName.toUpperCase(); + } else if (printCase == Keyword.CAPITALIZE) { symbolName = capitalize(symbolName, readtableCase); } - if (pkg == NIL) - { - if (printReadably || PRINT_GENSYM.symbolValue(thread) != NIL) - return "#:".concat(symbolName); - else + } + if (pkg == NIL) { + if (printReadably || PRINT_GENSYM.symbolValue(thread) != NIL) { + return "#:".concat(symbolName); + } else { return symbolName; } - if (pkg == PACKAGE_KEYWORD) + } + if (pkg == PACKAGE_KEYWORD) { return ":".concat(symbolName); + } // "Package prefixes are printed if necessary." (22.1.3.3.1) + // Here we also use a package-local nickname if appropriate. final Package currentPackage = (Package) _PACKAGE_.symbolValue(thread); - if (pkg == currentPackage) + if (pkg == currentPackage) { return symbolName; - if (currentPackage != null && currentPackage.uses(pkg)) - { + } + if (currentPackage != null && currentPackage.uses(pkg)) { // Check for name conflict in current package. if (currentPackage.findExternalSymbol(name) == null) if (currentPackage.findInternalSymbol(name) == null) if (((Package)pkg).findExternalSymbol(name) != null) return symbolName; - } + } // Has this symbol been imported into the current package? if (currentPackage.findExternalSymbol(name) == this) return symbolName; @@ -573,6 +562,17 @@ return symbolName; // Package prefix is necessary. String packageName = ((Package)pkg).getName(); + if (currentPackage.getLocallyNicknamedPackages().contains(pkg)) { + LispObject nicknames = currentPackage.getLocalPackageNicknames(); + while (nicknames != NIL) { + if (nicknames.car().cdr() == pkg) { + packageName = javaString(nicknames.car().car()); + nicknames = NIL; + } else { + nicknames = nicknames.cdr(); + } + } + } final boolean escapePackageName = needsEscape(packageName, readtableCase, thread); if (escapePackageName) { From rschlatte at common-lisp.net Tue Mar 5 21:07:12 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 05 Mar 2013 13:07:12 -0800 Subject: [armedbear-cvs] r14423 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Mar 5 13:07:11 2013 New Revision: 14423 Log: Don't error when re-adding an identical package-local nickname Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Tue Mar 5 12:45:10 2013 (r14422) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Tue Mar 5 13:07:11 2013 (r14423) @@ -787,8 +787,13 @@ localNicknames = new ConcurrentHashMap(); } if (localNicknames.containsKey(name)) { - return error(new LispError(name + " is already a nickname for " - + pack.getName())); + if (localNicknames.get(name) != pack) { + return error(new LispError(name + " is already a nickname for " + + pack.getName())); + } else { + // nothing to do + return pack; + } } else { localNicknames.put(name, pack); return pack; From mevenson at common-lisp.net Wed Mar 6 09:58:27 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 06 Mar 2013 01:58:27 -0800 Subject: [armedbear-cvs] r14424 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Mar 6 01:58:26 2013 New Revision: 14424 Log: Update to asdf-2.32. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Mar 5 13:07:11 2013 (r14423) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Mar 6 01:58:26 2013 (r14424) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.30: Another System Definition Facility. +;;; This is ASDF 2.32: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -71,8 +71,7 @@ (existing-version-number (and existing-version (read-from-string existing-major-minor))) (away (format nil "~A-~A" :asdf existing-version))) (when (and existing-version (< existing-version-number - #+abcl 2.25 #+clisp 2.27 #+clozure 2.27 - #+cmu 2.018 #+ecl 2.21 #+xcl 2.27)) + (or #+abcl 2.25 #+cmu 2.018 2.27))) (rename-package :asdf away) (when *load-verbose* (format t "; Renamed old ~A package away to ~A~%" :asdf away)))))) @@ -82,28 +81,28 @@ ;; ;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; -;; CAUTION: we must handle the first few packages specially for hot-upgrade. -;; asdf/package will be frozen as of ASDF 3 -;; to forever export the same exact symbols. -;; Any other symbol must be import-from'ed -;; and reexported in a different package -;; (alternatively the package may be dropped & replaced by one with a new name). -(defpackage :asdf/package +(defpackage :uiop/package + ;; CAUTION: we must handle the first few packages specially for hot-upgrade. + ;; This package definition MUST NOT change unless its name too changes; + ;; if/when it changes, don't forget to add new functions missing from below. + ;; Until then, asdf/package is frozen to forever + ;; import and export the same exact symbols as for ASDF 2.27. + ;; Any other symbol must be import-from'ed and re-export'ed in a different package. (:use :common-lisp) (:export #:find-package* #:find-symbol* #:symbol-call - #:intern* #:unintern* #:export* #:make-symbol* - #:symbol-shadowing-p #:home-package-p #:rehome-symbol + #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* + #:symbol-shadowing-p #:home-package-p #:symbol-package-name #:standard-common-lisp-symbol-p #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol - #:nuke-symbol-in-package #:nuke-symbol + #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol #:ensure-package-unused #:delete-package* - #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names + #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away #:package-definition-form #:parse-define-package-form #:ensure-package #:define-package)) -(in-package :asdf/package) +(in-package :uiop/package) ;;;; General purpose package utilities @@ -140,6 +139,12 @@ (let* ((package (find-package* package-designator)) (symbol (intern* name package))) (export (or symbol (list symbol)) package))) + (defun import* (symbol package-designator) + (import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadowing-import* (symbol package-designator) + (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadow* (name package-designator) + (shadow (string name) (find-package* package-designator))) (defun make-symbol* (name) (etypecase name (string (make-symbol name)) @@ -258,8 +263,8 @@ (multiple-value-bind (sym stat) (find-symbol name package) (when (and (member stat '(:internal :external)) (eq symbol sym)) (if (symbol-shadowing-p symbol package) - (shadowing-import (get-dummy-symbol symbol) package) - (unintern symbol package)))))) + (shadowing-import* (get-dummy-symbol symbol) package) + (unintern* symbol package)))))) (defun nuke-symbol (symbol &optional (packages (list-all-packages))) #+(or clisp clozure) (multiple-value-bind (setf-symbol kind) @@ -284,18 +289,18 @@ (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) (when old-package (if shadowing - (shadowing-import shadowing old-package)) - (unintern symbol old-package)) + (shadowing-import* shadowing old-package)) + (unintern* symbol old-package)) (cond (overwritten-symbol-shadowing-p - (shadowing-import symbol package)) + (shadowing-import* symbol package)) (t (when overwritten-symbol-status - (unintern overwritten-symbol package)) - (import symbol package))) + (unintern* overwritten-symbol package)) + (import* symbol package))) (if shadowing - (shadowing-import symbol old-package) - (import symbol old-package)) + (shadowing-import* symbol old-package) + (import* symbol old-package)) #+(or clisp clozure) (multiple-value-bind (setf-symbol kind) (get-setf-function-symbol symbol) @@ -308,7 +313,7 @@ (symbol-name setf-symbol) (symbol-package-name setf-symbol) (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) (when (symbol-package setf-symbol) - (unintern setf-symbol (symbol-package setf-symbol))) + (unintern* setf-symbol (symbol-package setf-symbol))) (setf (fdefinition new-setf-symbol) setf-function) (set-setf-function-symbol new-setf-symbol symbol kind)))) #+(or clisp clozure) @@ -435,7 +440,34 @@ (or (home-package-p import-me from-package) (symbol-package-name import-me)) (package-name to-package) status (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) - (shadowing-import import-me to-package)))))) + (shadowing-import* import-me to-package)))))) + (defun ensure-imported (import-me into-package &optional from-package) + (check-type import-me symbol) + (check-type into-package package) + (check-type from-package (or null package)) + (let ((name (symbol-name import-me))) + (multiple-value-bind (existing status) (find-symbol name into-package) + (cond + ((not status) + (import* import-me into-package)) + ((eq import-me existing)) + (t + (let ((shadowing-p (symbol-shadowing-p existing into-package))) + (note-package-fishiness + :ensure-imported name + (and from-package (package-name from-package)) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name into-package) + status + (and status (or (home-package-p existing into-package) (symbol-package-name existing))) + shadowing-p) + (cond + ((or shadowing-p (eq status :inherited)) + (shadowing-import* import-me into-package)) + (t + (unintern* existing into-package) + (import* import-me into-package)))))))) + (values)) (defun ensure-import (name to-package from-package shadowed imported) (check-type name string) (check-type to-package package) @@ -446,27 +478,18 @@ (when (null import-status) (note-package-fishiness :import-uninterned name (package-name from-package) (package-name to-package)) - (setf import-me (intern name from-package))) + (setf import-me (intern* name from-package))) (multiple-value-bind (existing status) (find-symbol name to-package) (cond - ((gethash name imported) - (unless (eq import-me existing) + ((and imported (gethash name imported)) + (unless (and status (eq import-me existing)) (error "Can't import ~S from both ~S and ~S" name (package-name (symbol-package existing)) (package-name from-package)))) ((gethash name shadowed) (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) (t - (setf (gethash name imported) t) - (unless (and status (eq import-me existing)) - (when status - (note-package-fishiness - :import name - (package-name from-package) - (or (home-package-p import-me from-package) (symbol-package-name import-me)) - (package-name to-package) status - (and status (or (home-package-p existing to-package) (symbol-package-name existing)))) - (unintern* existing to-package)) - (import import-me to-package))))))) + (setf (gethash name imported) t)))) + (ensure-imported import-me to-package from-package))) (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) (check-type name string) (check-type symbol symbol) @@ -484,7 +507,7 @@ (note-package-fishiness :import-uninterned name (package-name from-package) (package-name to-package) mixp) - (import symbol from-package) + (import* symbol from-package) (setf sp (package-name from-package))) (cond ((gethash name shadowed)) @@ -557,7 +580,7 @@ (defun symbol-recycled-p (sym recycle) (check-type sym symbol) (check-type recycle list) - (member (symbol-package sym) recycle)) + (and (member (symbol-package sym) recycle) t)) (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) (check-type name string) (check-type package package) @@ -591,6 +614,7 @@ (check-type symbol symbol) (check-type to-package package) (check-type recycle list) + (assert (equal name (symbol-name symbol))) (multiple-value-bind (existing status) (find-symbol name to-package) (unless (and status (eq symbol existing)) (let ((accessible @@ -604,7 +628,7 @@ (or (home-package-p existing to-package) (symbol-package-name existing)) status shadowing) (if (or (eq status :inherited) shadowing) - (shadowing-import symbol to-package) + (shadowing-import* symbol to-package) (unintern existing to-package)) t))))) (when (and accessible (eq status :external)) @@ -612,7 +636,8 @@ (defun ensure-exported (name symbol from-package &optional recycle) (dolist (to-package (package-used-by-list from-package)) (ensure-exported-to-user name symbol to-package recycle)) - (import symbol from-package) + (unless (eq from-package (symbol-package symbol)) + (ensure-imported symbol from-package)) (export* name from-package)) (defun ensure-export (name from-package &optional recycle) (multiple-value-bind (symbol status) (find-symbol* name from-package) @@ -694,9 +719,9 @@ (note-package-fishiness :shadow-imported (package-name package) name (symbol-package-name existing) status shadowing) - (shadowing-import dummy package) - (import dummy package))))))) - (shadow name package)) + (shadowing-import* dummy package) + (import* dummy package))))))) + (shadow* name package)) (loop :for (p . syms) :in shadowing-import-from :for pp = (find-package* p) :do (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) @@ -784,6 +809,9 @@ (pushnew :gcl2.6 *features*)) (t (pushnew :gcl2.7 *features*)))) + +;; Compatibility with whoever calls asdf/package +(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) ;;;; ------------------------------------------------------------------------- ;;;; Handle compatibility with multiple implementations. ;;; This file is for papering over the deficiencies and peculiarities @@ -792,11 +820,11 @@ ;;; A few functions are defined here, but actually exported from utility; ;;; from this package only common-lisp symbols are exported. -(asdf/package:define-package :asdf/common-lisp - (:nicknames :asdf/cl) - (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package) +(uiop/package:define-package :uiop/common-lisp + (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) + (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package) (:reexport :common-lisp) - (:recycle :asdf/common-lisp :asdf) + (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp @@ -808,7 +836,7 @@ #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist) #+mcl (:shadow #:user-homedir-pathname)) -(in-package :asdf/common-lisp) +(in-package :uiop/common-lisp) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") @@ -859,13 +887,13 @@ #+gcl2.6 (eval-when (:compile-toplevel :load-toplevel :execute) - (shadow 'type-of :asdf/common-lisp) - (shadowing-import 'system:*load-pathname* :asdf/common-lisp)) + (shadow 'type-of :uiop/common-lisp) + (shadowing-import 'system:*load-pathname* :uiop/common-lisp)) #+gcl2.6 (eval-when (:compile-toplevel :load-toplevel :execute) - (export 'type-of :asdf/common-lisp) - (export 'system:*load-pathname* :asdf/common-lisp)) + (export 'type-of :uiop/common-lisp) + (export 'system:*load-pathname* :uiop/common-lisp)) #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations. (eval-when (:load-toplevel :compile-toplevel :execute) @@ -933,24 +961,33 @@ ;;;; compatfmt: avoid fancy format directives when unsupported (eval-when (:load-toplevel :compile-toplevel :execute) - (defun remove-substrings (substrings string) + (defun frob-substrings (string substrings &optional frob) + (declare (optimize (speed 0) (safety 3) (debug 3))) (let ((length (length string)) (stream nil)) - (labels ((emit (start end) - (when (and (zerop start) (= end length)) - (return-from remove-substrings string)) + (labels ((emit-string (x &optional (start 0) (end (length x))) (when (< start end) (unless stream (setf stream (make-string-output-stream))) - (write-string string stream :start start :end end))) + (write-string x stream :start start :end end))) + (emit-substring (start end) + (when (and (zerop start) (= end length)) + (return-from frob-substrings string)) + (emit-string string start end)) (recurse (substrings start end) (cond ((>= start end)) - ((null substrings) (emit start end)) - (t (let* ((sub (first substrings)) + ((null substrings) (emit-substring start end)) + (t (let* ((sub-spec (first substrings)) + (sub (if (consp sub-spec) (car sub-spec) sub-spec)) + (fun (if (consp sub-spec) (cdr sub-spec) frob)) (found (search sub string :start2 start :end2 end)) (more (rest substrings))) (cond (found (recurse more start found) + (etypecase fun + (null) + (string (emit-string fun)) + (function (funcall fun sub #'emit-string))) (recurse substrings (+ found (length sub)) end)) (t (recurse more start end)))))))) @@ -959,20 +996,21 @@ (defmacro compatfmt (format) #+(or gcl genera) - (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format) + (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) #-(or gcl genera) format)) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF -(asdf/package:define-package :asdf/utility - (:recycle :asdf/utility :asdf) - (:use :asdf/common-lisp :asdf/package) +(uiop/package:define-package :uiop/utility + (:nicknames :asdf/utility) + (:recycle :uiop/utility :asdf/utility :asdf) + (:use :uiop/common-lisp :uiop/package) ;; import and reexport a few things defined in :asdf/common-lisp - (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings + (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) - (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt + (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: @@ -994,7 +1032,7 @@ #:call-with-muffled-conditions #:with-muffled-conditions #:lexicographic< #:lexicographic<= #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version -(in-package :asdf/utility) +(in-package :uiop/utility) ;;;; Defining functions in a way compatible with hot-upgrade: ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, @@ -1056,7 +1094,7 @@ (with-upgradability () (defvar *asdf-debug-utility* '(or (ignore-errors - (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp")) + (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp")) (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) "form that evaluates to the pathname to your favorite debugging utilities") @@ -1405,9 +1443,10 @@ ;;;; --------------------------------------------------------------------------- ;;;; Access to the Operating System -(asdf/package:define-package :asdf/os - (:recycle :asdf/os :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility) +(uiop/package:define-package :uiop/os + (:nicknames :asdf/os) + (:recycle :uiop/os :asdf/os :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features #:getenv #:getenvp ;; environment variables @@ -1418,7 +1457,7 @@ ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian #:parse-file-location-info #:parse-windows-shortcut)) -(in-package :asdf/os) +(in-package :uiop/os) ;;; Features (with-upgradability () @@ -1622,7 +1661,7 @@ #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+ecl (ext:getcwd) #+gcl (parse-namestring ;; this is a joke. Isn't there a better way? - (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines))) + (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines))) #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! #+lispworks (system:current-directory) #+mkcl (mk-ext:getcwd) @@ -1729,9 +1768,10 @@ ;; This layer allows for portable manipulation of pathname objects themselves, ;; which all is necessary prior to any access the filesystem or environment. -(asdf/package:define-package :asdf/pathname - (:recycle :asdf/pathname :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os) +(uiop/package:define-package :uiop/pathname + (:nicknames :asdf/pathname) + (:recycle :uiop/pathname :asdf/pathname :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) (:export ;; Making and merging pathnames, portably #:normalize-pathname-directory-component #:denormalize-pathname-directory-component @@ -1763,7 +1803,7 @@ #:directory-separator-for-host #:directorize-pathname-host-device #:translate-pathname* #:*output-translation-function*)) -(in-package :asdf/pathname) +(in-package :uiop/pathname) ;;; Normalizing pathnames across implementations @@ -2393,9 +2433,10 @@ ;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp filesystem access -(asdf/package:define-package :asdf/filesystem - (:recycle :asdf/pathname :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname) +(uiop/package:define-package :uiop/filesystem + (:nicknames :asdf/filesystem) + (:recycle :uiop/filesystem :asdf/pathname :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) (:export ;; Native namestrings #:native-namestring #:parse-native-namestring @@ -2416,7 +2457,7 @@ #:ensure-all-directories-exist #:rename-file-overwriting-target #:delete-file-if-exists)) -(in-package :asdf/filesystem) +(in-package :uiop/filesystem) ;;; Native namestrings, as seen by the operating system calls rather than Lisp (with-upgradability () @@ -2872,15 +2913,16 @@ ;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams -(asdf/package:define-package :asdf/stream - (:recycle :asdf/stream) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem) +(uiop/package:define-package :uiop/stream + (:nicknames :asdf/stream) + (:recycle :uiop/stream :asdf/stream :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) (:export #:*default-stream-element-type* #:*stderr* #:setup-stderr #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format #:*default-encoding* #:*utf-8-external-format* - #:with-safe-io-syntax #:call-with-safe-io-syntax + #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string #:with-output #:output-string #:with-input #:with-input-file #:call-with-input-file #:finish-outputs #:format! #:safe-format! @@ -2895,7 +2937,7 @@ #:call-with-temporary-file #:with-temporary-file #:add-pathname-suffix #:tmpize-pathname #:call-with-staging-pathname #:with-staging-pathname)) -(in-package :asdf/stream) +(in-package :uiop/stream) (with-upgradability () (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) @@ -2914,10 +2956,16 @@ ;;; Encodings (mostly hooks only; full support requires asdf-encodings) (with-upgradability () - (defvar *default-encoding* :default + (defparameter *default-encoding* + ;; preserve explicit user changes to something other than the legacy default :default + (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) + (unless (eq previous :default) previous)) + :utf-8) "Default encoding for source files. -The default value :default preserves the legacy behavior. -A future default might be :utf-8 or :autodetect +The default value :utf-8 is the portable thing. +The legacy behavior was :default. +If you (asdf:load-system :asdf-encodings) then +you will have autodetection via *encoding-detection-hook* below, reading emacs-style -*- coding: utf-8 -*- specifications, and falling back to utf-8 or latin1 if nothing is specified.") @@ -2975,7 +3023,11 @@ (*read-default-float-format* 'double-float) (*print-readably* nil) (*read-eval* nil)) - (funcall thunk))))) + (funcall thunk)))) + + (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) + (with-safe-io-syntax (:package package) + (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) ;;; Output to a stream or string, FORMAT-style @@ -3325,9 +3377,10 @@ ;;;; ------------------------------------------------------------------------- ;;;; Starting, Stopping, Dumping a Lisp image -(asdf/package:define-package :asdf/image - (:recycle :asdf/image :xcvb-driver) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os) +(uiop/package:define-package :uiop/image + (:nicknames :asdf/image) + (:recycle :uiop/image :asdf/image :xcvb-driver) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments @@ -3342,7 +3395,7 @@ #:call-image-restore-hook #:call-image-dump-hook #:restore-image #:dump-image #:create-image )) -(in-package :asdf/image) +(in-package :uiop/image) (with-upgradability () (defvar *lisp-interaction* t @@ -3653,9 +3706,10 @@ ;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. -(asdf/package:define-package :asdf/run-program - (:recycle :asdf/run-program :xcvb-driver) - (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream) +(uiop/package:define-package :uiop/run-program + (:nicknames :asdf/run-program) + (:recycle :uiop/run-program :asdf/run-program :xcvb-driver) + (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export ;;; Escaping the command invocation madness #:easy-sh-character-p #:escape-sh-token #:escape-sh-command @@ -3668,7 +3722,7 @@ #:subprocess-error #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process )) -(in-package :asdf/run-program) +(in-package :uiop/run-program) ;;;; ----- Escaping strings for the shell ----- @@ -4042,10 +4096,11 @@ ;;;; ------------------------------------------------------------------------- ;;;; Support to build (compile and load) Lisp files -(asdf/package:define-package :asdf/lisp-build - (:recycle :asdf/interface :asdf :asdf/lisp-build) - (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image) +(uiop/package:define-package :uiop/lisp-build + (:nicknames :asdf/lisp-build) + (:recycle :uiop/lisp-build :asdf/lisp-build :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) (:export ;; Variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* @@ -4063,12 +4118,13 @@ #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* + #:enable-deferred-warnings-check #:disable-deferred-warnings-check #:current-lisp-file-pathname #:load-pathname #:lispize-pathname #:compile-file-type #:call-around-hook #:compile-file* #:compile-file-pathname* #:load* #:load-from-string #:combine-fasls) (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) -(in-package :asdf/lisp-build) +(in-package :uiop/lisp-build) (with-upgradability () (defvar *compile-file-warnings-behaviour* @@ -4233,7 +4289,7 @@ ((or number character simple-string pathname) sexp) (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) - + (defun unreify-simple-sexp (sexp) (etypecase sexp ((or symbol number character simple-string pathname) sexp) @@ -4255,15 +4311,21 @@ (destructuring-bind (&key filename start-pos end-pos source) source-note (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos :source (unreify-source-note source))))) + (defun unsymbolify-function-name (name) + (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) + `(setf ,setfed) + name)) + (defun symbolify-function-name (name) + (if (and (consp name) (eq (first name) 'setf)) + (let ((setfed (second name))) + (gethash setfed ccl::%setf-function-names%)) + name)) (defun reify-function-name (function-name) - (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%)) - `(setf ,setfed) - function-name)) + (let ((name (or (first function-name) ;; defun: extract the name + (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers + (list name))) (defun unreify-function-name (function-name) - (if (and (consp function-name) (eq (first function-name) 'setf)) - (let ((setfed (second function-name))) - (gethash setfed ccl::%setf-function-names%)) - function-name)) + function-name) (defun reify-deferred-warning (deferred-warning) (with-accessors ((warning-type ccl::compiler-warning-warning-type) (args ccl::compiler-warning-args) @@ -4271,8 +4333,11 @@ (function-name ccl:compiler-warning-function-name)) deferred-warning (list :warning-type warning-type :function-name (reify-function-name function-name) :source-note (reify-source-note source-note) - :args (destructuring-bind (fun . formals) args - (cons (reify-function-name fun) formals))))) + :args (destructuring-bind (fun formals env) args + (declare (ignorable env)) + (list (unsymbolify-function-name fun) + (mapcar (constantly nil) formals) + nil))))) (defun unreify-deferred-warning (reified-deferred-warning) (destructuring-bind (&key warning-type function-name source-note args) reified-deferred-warning @@ -4282,7 +4347,7 @@ :source-note (unreify-source-note source-note) :warning-type warning-type :args (destructuring-bind (fun . formals) args - (cons (unreify-function-name fun) formals)))))) + (cons (symbolify-function-name fun) formals)))))) #+(or cmu scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit @@ -4478,9 +4543,15 @@ ((:clozure :ccl) "ccl-warnings") ((:scl) "scl-warnings"))) - (defvar *warnings-file-type* (warnings-file-type) + (defvar *warnings-file-type* nil "Type for warnings files") + (defun enable-deferred-warnings-check () + (setf *warnings-file-type* (warnings-file-type))) + + (defun disable-deferred-warnings-check () + (setf *warnings-file-type* nil)) + (defun warnings-file-p (file &optional implementation-type) (if-let (type (if implementation-type (warnings-file-type implementation-type) @@ -4502,7 +4573,7 @@ (unreify-deferred-warnings (handler-case (safe-read-file-form file) (error (c) - (delete-file-if-exists file) + ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging (push c file-errors) nil)))))) (dolist (error file-errors) (error error)) @@ -4711,10 +4782,11 @@ ;;;; --------------------------------------------------------------------------- ;;;; Generic support for configuration files -(asdf/package:define-package :asdf/configuration - (:recycle :asdf/configuration :asdf) - (:use :asdf/common-lisp :asdf/utility - :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image) +(uiop/package:define-package :uiop/configuration + (:nicknames :asdf/configuration) + (:recycle :uiop/configuration :asdf/configuration :asdf) + (:use :uiop/common-lisp :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) (:export #:get-folder-path #:user-configuration-directories #:system-configuration-directories @@ -4726,7 +4798,7 @@ #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) -(in-package :asdf/configuration) +(in-package :uiop/configuration) (with-upgradability () (define-condition invalid-configuration () @@ -5008,17 +5080,18 @@ ;;;; ------------------------------------------------------------------------- ;;; Hacks for backward-compatibility of the driver -(asdf/package:define-package :asdf/backward-driver - (:recycle :asdf/backward-driver :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image - :asdf/run-program :asdf/lisp-build - :asdf/configuration) +(uiop/package:define-package :uiop/backward-driver + (:nicknames :asdf/backward-driver) + (:recycle :uiop/backward-driver :asdf/backward-driver :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/pathname :uiop/stream :uiop/os :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration) (:export #:coerce-pathname #:component-name-to-pathname-components #+(or ecl mkcl) #:compile-file-keeping-object )) -(in-package :asdf/backward-driver) +(in-package :uiop/backward-driver) ;;;; Backward compatibility with various pathname functions. @@ -5048,19 +5121,19 @@ ;;;; --------------------------------------------------------------------------- ;;;; Re-export all the functionality in asdf/driver -(asdf/package:define-package :asdf/driver - (:nicknames :asdf-driver :asdf-utils) - (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image - :asdf/run-program :asdf/lisp-build - :asdf/configuration :asdf/backward-driver) +(uiop/package:define-package :uiop/driver + (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration :uiop/backward-driver) (:reexport ;; NB: excluding asdf/common-lisp ;; which include all of CL with compatibility modifications on select platforms. - :asdf/package :asdf/utility - :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image - :asdf/run-program :asdf/lisp-build - :asdf/configuration :asdf/backward-driver)) + :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration :uiop/backward-driver)) ;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 @@ -5115,7 +5188,7 @@ ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "2.30") + (asdf-version "2.32") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -5182,16 +5255,11 @@ (unless (equal old-version new-version) (push new-version *previous-asdf-versions*) (when old-version - (cond - ((version-compatible-p new-version old-version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - old-version new-version)) - ((version-compatible-p old-version new-version) - (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") - old-version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - old-version new-version))) + (if (version<= new-version old-version) + (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) (call-functions (reverse *post-upgrade-cleanup-hook*)) t)))) @@ -5200,7 +5268,7 @@ We need do that before we operate on anything that may possibly depend on ASDF." (let ((*load-print* nil) (*compile-print* nil)) - (handler-bind (((or style-warning warning) #'muffle-warning)) + (handler-bind (((or style-warning) #'muffle-warning)) (symbol-call :asdf :load-system :asdf :verbose nil)))) (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) @@ -5219,7 +5287,8 @@ #:file-component #:source-file #:c-source-file #:java-source-file #:static-file #:doc-file #:html-file - #:source-file-type ;; backward-compatibility + #:file-type + #:source-file-type #:source-file-explicit-type ;; backward-compatibility #:component-in-order-to #:component-sibling-dependencies #:component-if-feature #:around-compile-hook #:component-description #:component-long-description @@ -5350,7 +5419,8 @@ (defclass file-component (child-component) ((type :accessor file-type :initarg :type))) ; no default (defclass source-file (file-component) - ((type :initform nil))) ;; NB: many systems have come to rely on this default. + ((type :accessor source-file-explicit-type ;; backward-compatibility + :initform nil))) ;; NB: many systems have come to rely on this default. (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) @@ -5627,13 +5697,13 @@ (setf (gethash key *asdf-cache*) value-list) value-list))) - (defun consult-asdf-cache (key thunk) + (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) (if foundp (apply 'values results) - (set-asdf-cache-entry key (multiple-value-list (funcall thunk))))) - (funcall thunk))) + (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) + (call-function thunk))) (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () , at body))) @@ -5666,7 +5736,7 @@ :asdf/component :asdf/system :asdf/cache) (:export #:remove-entry-from-registry #:coerce-entry-to-directory - #:coerce-name #:primary-system-name + #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd #:with-system-definitions #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems #:system-definition-error #:missing-component #:missing-requires #:missing-parent @@ -5728,6 +5798,9 @@ ;; the first of the slash-separated components. (first (split-string (coerce-name name) :separator "/"))) + (defun coerce-filename (name) + (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) + (defvar *defined-systems* (make-hash-table :test 'equal) "This is a hash table whose keys are strings, being the names of the systems, and whose values are pairs, the first @@ -5891,6 +5964,25 @@ (list new) (subseq *central-registry* (1+ position)))))))))) + (defvar *preloaded-systems* (make-hash-table :test 'equal)) + + (defun make-preloaded-system (name keys) + (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys))) + + (defun sysdef-preloaded-system-search (requested) + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (make-preloaded-system name keys))))) + + (defun register-preloaded-system (system-name &rest keys) + (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) + + (register-preloaded-system "asdf" :version *asdf-version*) + (register-preloaded-system "asdf-driver" :version *asdf-version*) + (defmethod find-system ((name null) &optional (error-p t)) (declare (ignorable name)) (when error-p @@ -5912,6 +6004,12 @@ (let ((*systems-being-defined* (make-hash-table :test 'equal))) (call-with-asdf-cache thunk)))) + (defun clear-systems-being-defined () + (when *systems-being-defined* + (clrhash *systems-being-defined*))) + + (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined) + (defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () , at body))) @@ -5940,6 +6038,46 @@ (with-muffled-loader-conditions () (load* pathname :external-format external-format))))))) + (defvar *old-asdf-systems* (make-hash-table :test 'equal)) + + (defun check-not-old-asdf-system (name pathname) + (or (not (equal name "asdf")) + (null pathname) + (let* ((version-pathname (subpathname pathname "version.lisp-expr")) + (version (and (probe-file* version-pathname :truename nil) + (read-file-form version-pathname))) + (old-version (asdf-version))) + (or (version<= old-version version) + (let ((old-pathname + (if-let (pair (system-registered-p "asdf")) + (system-source-file (cdr pair)))) + (key (list pathname old-version))) + (unless (gethash key *old-asdf-systems*) + (setf (gethash key *old-asdf-systems*) t) + (warn "~@<~ + You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ + or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ + ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ + Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ + and having an old version registered is a configuration error. ~ + ASDF will ignore this configured system rather than downgrade itself. ~ + In the future, you may want to either: ~ + (a) upgrade this configured ASDF to a newer version, ~ + (b) install a newer ASDF and register it in front of the former in your configuration, or ~ + (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ + Note that the older ASDF might be registered implicitly through configuration inherited ~ + from your system installation, in which case you might have to specify ~ + :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ + or other source-registry configuration file, environment variable or lisp parameter. ~ + Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ + that you might want to upgrade (if a recent enough version is available) ~ + or else remove altogether (since most implementations ship with a recent asdf); ~ + if you lack the system administration rights to upgrade or remove this package, ~ + then you might indeed want to either install and register a more recent version, ~ + or use :ignore-inherited-configuration to avoid registering the old one. ~ + Please consult ASDF documentation and/or experts.~@:>~%" + old-version old-pathname version pathname))))))) + (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME @@ -5957,12 +6095,20 @@ (previous-time (car in-memory)) (found (search-for-system-definition name)) (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous)))) - (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) (foundp (and (or found-system pathname previous) t))) (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) (values foundp found-system pathname previous previous-time))) (defmethod find-system ((name string) &optional (error-p t)) @@ -5988,7 +6134,7 @@ (translate-logical-pathname pathname) (translate-logical-pathname previous-pathname)))) (stamp<= stamp previous-time)))))) - ;; only load when it's a pathname that is different or has newer content + ;; only load when it's a pathname that is different or has newer content, and not an old asdf (load-asd pathname :name name))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (return @@ -6002,21 +6148,7 @@ (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@") name)) - (initialize-source-registry)))))) - - (defvar *preloaded-systems* (make-hash-table :test 'equal)) - - (defun sysdef-preloaded-system-search (requested) - (let ((name (coerce-name requested))) - (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) - (when foundp - (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys))))) - - (defun register-preloaded-system (system-name &rest keys) - (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) - - (register-preloaded-system "asdf" :version *asdf-version*) - (register-preloaded-system "asdf-driver" :version *asdf-version*)) + (initialize-source-registry))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -6152,15 +6284,13 @@ ;;;; Operations (asdf/package:define-package :asdf/operation - (:recycle :asdf/operation :asdf) + (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) (:export #:operation #:operation-original-initargs ;; backward-compatibility only. DO NOT USE. #:build-op ;; THE generic operation - #:*operations* - #:make-operation - #:find-operation)) + #:*operations* #:make-operation #:find-operation #:feature)) (in-package :asdf/operation) ;;; Operation Classes @@ -6202,7 +6332,10 @@ (declare (ignorable context)) spec) (defmethod find-operation (context (spec symbol)) - (apply 'make-operation spec (operation-original-initargs context))) + (unless (member spec '(nil feature)) + ;; NIL designates itself, i.e. absence of operation + ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS + (apply 'make-operation spec (operation-original-initargs context)))) (defmethod operation-original-initargs ((context symbol)) (declare (ignorable context)) nil) @@ -6226,7 +6359,7 @@ #:input-files #:output-files #:output-file #:operation-done-p #:action-status #:action-stamp #:action-done-p #:component-operation-time #:mark-operation-done #:compute-action-stamp - #:perform #:perform-with-restarts #:retry #:accept #:feature + #:perform #:perform-with-restarts #:retry #:accept #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan #:action-path #:find-action #:stamp #:done-p)) (in-package :asdf/action) @@ -6305,17 +6438,19 @@ "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: - ( *), where is a class - designator and each is a component - designator, which means that the component depends on + ( *), where is an operation designator + with respect to FIND-OPERATION in the context of the OPERATION argument, + and each is a component designator with respect to + FIND-COMPONENT in the context of the COMPONENT argument, + and means that the component depends on having been performed on each ; or (FEATURE ), which means that the component depends - on 's presence in *FEATURES*. + on the expression satisfying FEATUREP. + (This is DEPRECATED -- use :IF-FEATURE instead.) Methods specialized on subclasses of existing component types - should usually append the results of CALL-NEXT-METHOD to the - list.")) + should usually append the results of CALL-NEXT-METHOD to the list.")) (defgeneric component-self-dependencies (operation component)) (define-convenience-action-methods component-depends-on (operation component)) (define-convenience-action-methods component-self-dependencies (operation component)) @@ -6520,7 +6655,8 @@ (:recycle :asdf/lisp-action :asdf) (:intern #:proclamations #:flags) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) + :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system + :asdf/operation :asdf/action) (:export #:try-recompiling #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp @@ -6621,7 +6757,7 @@ "~/asdf-action::format-action/" (list (cons o c)))))) (defun report-file-p (f) - (equal (pathname-type f) "build-report")) + (equalp (pathname-type f) "build-report")) (defun perform-lisp-warnings-check (o c) (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) (actual-warnings-files (loop :for w :in expected-warnings-files @@ -6674,7 +6810,7 @@ (defmethod output-files ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) (if-let ((pathname (component-pathname c))) - (list (subpathname pathname (component-name c) :type "build-report")))))) + (list (subpathname pathname (coerce-filename c) :type "build-report")))))) ;;; load-op (with-upgradability () @@ -6771,6 +6907,7 @@ (declare (ignorable o)) `((load-op ,c) ,@(call-next-method)))) + ;;;; ------------------------------------------------------------------------- ;;;; Plan @@ -6945,11 +7082,12 @@ (with-upgradability () (defun map-direct-dependencies (operation component fun) (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) - :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature - :do (loop :with dep-o = (find-operation operation dep-o-spec) - :for dep-c-spec :in dep-c-specs - :for dep-c = (resolve-dependency-spec component dep-c-spec) - :do (funcall fun dep-o dep-c)))) + :for dep-o = (find-operation operation dep-o-spec) + :when dep-o + :do (loop :for dep-c-spec :in dep-c-specs + :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) + :when dep-c + :do (funcall fun dep-o dep-c)))) (defun reduce-direct-dependencies (operation component combinator seed) (map-direct-dependencies @@ -7230,30 +7368,9 @@ (in-package :asdf/operate) (with-upgradability () - (defgeneric* (operate) (operation component &key &allow-other-keys)) - (define-convenience-action-methods - operate (operation component &key) - :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. - :if-no-component (error 'missing-component :requires component)) - - (defvar *systems-being-operated* nil - "A boolean indicating that some systems are being operated on") - - (defmethod operate :around (operation component - &key verbose - (on-warnings *compile-file-warnings-behaviour*) - (on-failure *compile-file-failure-behaviour*) &allow-other-keys) - (declare (ignorable operation component)) - ;; Setup proper bindings around any operate call. - (with-system-definitions () - (let* ((*verbose-out* (and verbose *standard-output*)) - (*compile-file-warnings-behaviour* on-warnings) - (*compile-file-failure-behaviour* on-failure)) - (call-next-method)))) - - (defmethod operate ((operation operation) (component component) - &rest args &key version &allow-other-keys) - "Operate does three things: + (defgeneric* (operate) (operation component &key &allow-other-keys) + (:documentation + "Operate does three things: 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). @@ -7271,30 +7388,60 @@ without recursively forcing the other systems we depend on. :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list -:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced." - (let* (;; I'd like to remove-plist-keys :force :force-not :verbose, - ;; but swank.asd relies on :force (!). - (systems-being-operated *systems-being-operated*) +:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced.")) + + (define-convenience-action-methods + operate (operation component &key) + ;; I'd like to at least remove-plist-keys :force :force-not :verbose, + ;; but swank.asd relies on :force (!). + :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. + :if-no-component (error 'missing-component :requires component)) + + (defvar *systems-being-operated* nil + "A boolean indicating that some systems are being operated on") + + (defmethod operate :around (operation component &rest keys + &key verbose + (on-warnings *compile-file-warnings-behaviour*) + (on-failure *compile-file-failure-behaviour*) &allow-other-keys) + (declare (ignorable operation component)) + (let* ((systems-being-operated *systems-being-operated*) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) - (system (component-system component))) - (setf (gethash (coerce-name system) *systems-being-operated*) system) - (unless (version-satisfies component version) - (error 'missing-component-of-version :requires component :version version)) + (operation-name (reify-symbol (etypecase operation + (operation (type-of operation)) + (symbol operation)))) + (component-path (typecase component + (component (component-find-path component)) + (t component)))) ;; Before we operate on any system, make sure ASDF is up-to-date, ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. (unless systems-being-operated - (let ((operation-name (reify-symbol (type-of operation))) - (component-path (component-find-path component))) - (when (upgrade-asdf) - ;; If we were upgraded, restart OPERATE the hardest of ways, for - ;; its function may have been redefined, its symbol uninterned, its package deleted. - (return-from operate - (apply (find-symbol* 'operate :asdf) - (unreify-symbol operation-name) - component-path args))))) - (let ((plan (apply 'traverse operation system args))) - (perform-plan plan) - (values operation plan)))) + (when (upgrade-asdf) + ;; If we were upgraded, restart OPERATE the hardest of ways, for + ;; its function may have been redefined, its symbol uninterned, its package deleted. + (return-from operate + (apply (find-symbol* 'operate :asdf) + (unreify-symbol operation-name) + component-path keys)))) + ;; Setup proper bindings around any operate call. + (with-system-definitions () + (let* ((*verbose-out* (and verbose *standard-output*)) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure)) + (call-next-method))))) + + (defmethod operate :before ((operation operation) (component component) + &key version &allow-other-keys) + (let ((system (component-system component))) + (setf (gethash (coerce-name system) *systems-being-operated*) system)) + (unless (version-satisfies component version) + (error 'missing-component-of-version :requires component :version version))) + + (defmethod operate ((operation operation) (component component) + &rest keys &key &allow-other-keys) + (let ((plan (apply 'traverse operation component keys))) + (perform-plan plan) + (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) (apply 'operate operation component args)) @@ -7354,18 +7501,54 @@ (defun require-system (s &rest keys &key &allow-other-keys) (apply 'load-system s :force-not (already-loaded-systems) keys)) + (defvar *modules-being-required* nil) + + (defclass require-system (system) + ((module :initarg :module :initform nil :accessor required-module))) + + (defmethod perform ((o compile-op) (c require-system)) + (declare (ignorable o c)) + nil) + + (defmethod perform ((o load-op) (s require-system)) + (declare (ignorable o)) + (let* ((module (or (required-module s) (coerce-name s))) + (*modules-being-required* (cons module *modules-being-required*))) + (assert (null (component-children s))) + (require module))) + + (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) + (declare (ignorable component combinator)) + (unless (length=n-p arguments 1) + (error (compatfmt "~@") + (cons combinator arguments) component combinator)) + (let* ((module (car arguments)) + (name (string-downcase module)) + (system (find-system name nil))) + (assert module) + ;;(unless (typep system '(or null require-system)) + ;; (warn "~S depends on ~S but ~S is registered as a ~S" + ;; component (cons combinator arguments) module (type-of system))) + (or system (let ((system (make-instance 'require-system :name name))) + (register-system system) + system)))) + (defun module-provide-asdf (name) - (handler-bind - ((style-warning #'muffle-warning) - (missing-component (constantly nil)) - (error #'(lambda (e) - (format *error-output* (compatfmt "~@~%") - name e)))) - (let ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) - (when system - (require-system system :verbose nil) - t))))) + (let ((module (string-downcase name))) + (unless (member module *modules-being-required* :test 'equal) + (let ((*modules-being-required* (cons module *modules-being-required*)) + #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal))) + (handler-bind + ((style-warning #'muffle-warning) + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream))) + (let ((system (find-system module nil))) + (when system + (require-system system :verbose nil) + t))))))))) ;;;; Some upgrade magic @@ -7645,27 +7828,27 @@ (initialize-output-translations))) (defun* (apply-output-translations) (path) - #+cormanlisp (resolve-symlinks* path) #-cormanlisp - (etypecase path - (logical-pathname - path) - ((or pathname string) - (ensure-output-translations) - (loop* :with p = (resolve-symlinks* path) - :for (source destination) :in (car *output-translations*) - :for root = (when (or (eq source t) - (and (pathnamep source) - (not (absolute-pathname-p source)))) - (pathname-root p)) - :for absolute-source = (cond - ((eq source t) (wilden root)) - (root (merge-pathnames* source root)) - (t source)) - :when (or (eq source t) (pathname-match-p p absolute-source)) - :return (translate-pathname* p absolute-source destination root source) - :finally (return p))))) + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop* :with p = (resolve-symlinks* path) + :for (source destination) :in (car *output-translations*) + :for root = (when (or (eq source t) + (and (pathnamep source) + (not (absolute-pathname-p source)))) + (pathname-root p)) + :for absolute-source = (cond + ((eq source t) (wilden root)) + (root (merge-pathnames* source root)) + (t source)) + :when (or (eq source t) (pathname-match-p p absolute-source)) + :return (translate-pathname* p absolute-source destination root source) + :finally (return p))))) ;; Hook into asdf/driver's output-translation mechanism + #-cormanlisp (setf *output-translation-function* 'apply-output-translations) #+abcl @@ -8155,8 +8338,9 @@ (or (loop :for symbol :in (list type (find-symbol* type *package* nil) - (find-symbol* type :asdf/interface nil)) - :for class = (and symbol (find-class* symbol nil)) + (find-symbol* type :asdf/interface nil) + (and (stringp type) (safe-read-from-string type :package :asdf/interface))) + :for class = (and symbol (symbolp symbol) (find-class* symbol nil)) :when (and class (#-cormanlisp subtypep #+cormanlisp cl::subclassp class (find-class* 'component))) @@ -8174,7 +8358,7 @@ (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (format s (compatfmt "~@") + (format s (compatfmt "~@") (duplicate-names-name c))))) (defun sysdef-error-component (msg type name value) @@ -8194,18 +8378,34 @@ (sysdef-error-component ":components must be NIL or a list of components." type name components))) - (defun normalize-version (form pathname) - (etypecase form - ((or string null) form) - (real - (asdf-message "Invalid use of real number ~D as :version in ~S. Substituting a string." - form pathname) - (format nil "~D" form)) ;; 1.0 is "1.0" - (cons - (ecase (first form) - ((:read-file-form) - (destructuring-bind (subpath &key (at 0)) (rest form) - (safe-read-file-form (subpathname pathname subpath) :at at)))))))) + (defun* (normalize-version) (form &key pathname component parent) + (labels ((invalid (&optional (continuation "using NIL instead")) + (warn (compatfmt "~@") + form component parent pathname continuation)) + (invalid-parse (control &rest args) + (unless (builtin-system-p (find-component parent component)) + (apply 'warn control args) + (invalid)))) + (if-let (v (typecase form + ((or string null) form) + (real + (invalid "Substituting a string") + (format nil "~D" form)) ;; 1.0 becomes "1.0" + (cons + (case (first form) + ((:read-file-form) + (destructuring-bind (subpath &key (at 0)) (rest form) + (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user))) + ((:read-file-line) + (destructuring-bind (subpath &key (at 0)) (rest form) + (read-file-lines (subpathname pathname subpath) :at at))) + (otherwise + (invalid)))) + (t + (invalid)))) + (if-let (pv (parse-version v #'invalid-parse)) + (unparse-version pv) + (invalid)))))) ;;; Main parsing function @@ -8218,7 +8418,7 @@ ;; remove-plist-keys form. important to keep them in sync components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial - do-first if-component-dep-fails (version nil versionp) + do-first if-component-dep-fails version ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) @@ -8249,13 +8449,10 @@ (apply 'reinitialize-instance component args) (setf component (apply 'make-instance (class-for-type parent type) args))) (component-pathname component) ; eagerly compute the absolute pathname - (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous + (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous (when (and (typep component 'system) (not bspp)) - (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir))) - (setf version (normalize-version version sysdir))) - (when (and versionp version (not (parse-version version nil))) - (warn (compatfmt "~@") - version name parent)) + (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) + (setf version (normalize-version version :component name :parent parent :pathname sysfile))) ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. ;; A better fix is required. (setf (slot-value component 'version) version) @@ -8299,6 +8496,7 @@ (component-options (remove-plist-key :class options)) (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect (resolve-dependency-spec nil spec)))) + (setf (gethash name *systems-being-defined*) system) (apply 'load-systems defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. @@ -8324,7 +8522,7 @@ (:export #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op - #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files + #:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op #:program-op #:compiled-file #:precompiled-system #:prebuilt-system @@ -8458,7 +8656,7 @@ (unless name-suffix-p (setf (slot-value instance 'name-suffix) (unless (typep instance 'program-op) - (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system")))) + (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames (when (typep instance 'monolithic-bundle-op) (destructuring-bind (&rest original-initargs &key lisp-files prologue-code epilogue-code @@ -8483,10 +8681,10 @@ (defun bundlable-file-p (pathname) (let ((type (pathname-type pathname))) (declare (ignorable type)) - (or #+ecl (or (equal type (compile-file-type :type :object)) - (equal type (compile-file-type :type :static-library))) - #+mkcl (equal type (compile-file-type :fasl-p nil)) - #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) + (or #+ecl (or (equalp type (compile-file-type :type :object)) + (equalp type (compile-file-type :type :static-library))) + #+mkcl (equalp type (compile-file-type :fasl-p nil)) + #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) (defgeneric* (trivial-system-p) (component)) @@ -8654,7 +8852,7 @@ (perform (find-operation o 'load-op) c)) (defmethod perform ((o load-fasl-op) (c compiled-file)) (perform (find-operation o 'load-op) c)) - (defmethod perform (o (c compiled-file)) + (defmethod perform ((o operation) (c compiled-file)) (declare (ignorable o c)) nil)) @@ -8713,8 +8911,8 @@ #-(or ecl mkcl) (defmethod perform ((o fasl-op) (c system)) (let* ((input-files (input-files o c)) - (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=)) - (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=)) + (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) + (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) (output-files (output-files o c)) (output-file (first output-files))) (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c)) @@ -8734,6 +8932,9 @@ (declare (ignorable o)) (bundle-output-files (find-operation o 'fasl-op) s)) + (defmethod perform ((o load-op) (s precompiled-system)) + (perform-lisp-load-fasl o s)) + (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) (declare (ignorable o)) `((load-op ,s) ,@(call-next-method)))) @@ -9091,11 +9292,13 @@ #:monolithic-load-compiled-concatenated-source-op #:operation-monolithic-p #:required-components + #:component-loaded-p #:component #:parent-component #:child-component #:system #:module #:file-component #:source-file #:c-source-file #:java-source-file #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file + #:file-type #:source-file-type #:component-children ; component accessors @@ -9176,7 +9379,7 @@ #:apply-output-translations #:compile-file* #:compile-file-pathname* - #:*warnings-file-type* + #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check #:enable-asdf-binary-locations-compatibility #:*default-source-registries* #:*source-registry-parameter* @@ -9239,11 +9442,12 @@ (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* (loop :for f :in #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* - :unless (eq f 'module-provide-asdf) - :collect #'(lambda (name) - (let ((l (multiple-value-list (funcall f name)))) - (and (first l) (register-pre-built-system (coerce-name name))) - (values-list l))))))) + :collect + (if (eq f 'module-provide-asdf) f + #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l)))))))) ;;;; Done! @@ -9262,6 +9466,3 @@ (asdf-message ";; ASDF, version ~a~%" (asdf-version))) -;;; Local Variables: -;;; mode: lisp -;;; End: From mevenson at common-lisp.net Wed Mar 6 09:58:32 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 06 Mar 2013 01:58:32 -0800 Subject: [armedbear-cvs] r14425 - trunk/abcl Message-ID: Author: mevenson Date: Wed Mar 6 01:58:27 2013 New Revision: 14425 Log: Restore runnable tests from build.xml. Fixes #310. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Mar 6 01:58:26 2013 (r14424) +++ trunk/abcl/build.xml Wed Mar 6 01:58:27 2013 (r14425) @@ -625,9 +625,6 @@ toFile="${dist.dir}/abcl-${abcl.version}.jar"/> - - - @@ -947,8 +944,10 @@ classname="org.armedbear.lisp.Main"> - - + + + + @@ -975,8 +974,10 @@ - - + + + + @@ -991,8 +992,10 @@ classname="org.armedbear.lisp.Main"> - - + + + + @@ -1007,8 +1010,10 @@ classname="org.armedbear.lisp.Main"> - - + + + + From ehuelsmann at common-lisp.net Thu Mar 7 21:38:28 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 07 Mar 2013 13:38:28 -0800 Subject: [armedbear-cvs] r14426 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Mar 7 13:38:26 2013 New Revision: 14426 Log: Fix #274: Infinite loop when compiling COM.INFORMATIMAGO.COMMON-LISP.CESARUM. Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Wed Mar 6 01:58:27 2013 (r14425) +++ trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Thu Mar 7 13:38:26 2013 (r14426) @@ -75,7 +75,8 @@ (return)) (when (null object) (return-from df-check-cons)) - (df-register-circularity object))) + (when (eq :circular (df-register-circularity object)) + (return)))) (defun df-check-vector (object) (dotimes (index (length object)) @@ -267,6 +268,7 @@ (*circularity* (make-hash-table :test #'eq)) (*instance-forms* (make-hash-table :test #'eq)) (*circle-counter* 0)) +;; (print form) (unless *prevent-fasl-circle-detection* (df-check-object form)) (dump-object form stream))) From mevenson at common-lisp.net Fri Mar 8 14:53:49 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 08 Mar 2013 06:53:49 -0800 Subject: [armedbear-cvs] r14427 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Mar 8 06:53:47 2013 New Revision: 14427 Log: Fix warn on redefinition for case when symbol has no source pathname. This can occur for system symbols implemented in Java. Modified: trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp Modified: trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp Thu Mar 7 13:38:26 2013 (r14426) +++ trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp Fri Mar 8 06:53:47 2013 (r14427) @@ -35,26 +35,27 @@ (defun check-redefinition (name) (when (and *warn-on-redefinition* (fboundp name) (not (autoloadp name))) - (cond ((symbolp name) - (let ((old-source - (if (keywordp (source-pathname name)) - (source-pathname name) - (truename (source-pathname name)))) - (current-source - (if (not *source*) - :top-level - (truename *source*)))) - (cond ((equal old-source - current-source)) ; OK - (t - (if (eq current-source :top-level) - (style-warn "redefining ~S at top level" name) - (let ((*package* +cl-package+)) - (if (eq old-source :top-level) - (style-warn "redefining ~S in ~S (previously defined at top level)" - name current-source) - (style-warn "redefining ~S in ~S (previously defined in ~S)" - name current-source old-source))))))))))) + (when (and (symbolp name) + (source-pathname name)) + (let ((old-source + (if (keywordp (source-pathname name)) + (source-pathname name) + (truename (source-pathname name)))) + (current-source + (if (not *source*) + :top-level + (truename *source*)))) + (cond ((equal old-source + current-source)) ; OK + (t + (if (eq current-source :top-level) + (style-warn "redefining ~S at top level" name) + (let ((*package* +cl-package+)) + (if (eq old-source :top-level) + (style-warn "redefining ~S in ~S (previously defined at top level)" + name current-source) + (style-warn "redefining ~S in ~S (previously defined in ~S)" + name current-source old-source)))))))))) (defun record-source-information (name &optional source-pathname source-position) (unless source-pathname From rschlatte at common-lisp.net Sat Mar 9 13:02:31 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 09 Mar 2013 05:02:31 -0800 Subject: [armedbear-cvs] r14428 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Mar 9 05:02:30 2013 New Revision: 14428 Log: Fix return value of add-package-local-nickname Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Fri Mar 8 06:53:47 2013 (r14427) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Sat Mar 9 05:02:30 2013 (r14428) @@ -792,11 +792,11 @@ + pack.getName())); } else { // nothing to do - return pack; + return this; } } else { localNicknames.put(name, pack); - return pack; + return this; } } From rschlatte at common-lisp.net Sat Mar 9 13:02:39 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 09 Mar 2013 05:02:39 -0800 Subject: [armedbear-cvs] r14429 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Mar 9 05:02:37 2013 New Revision: 14429 Log: When deleting a package, remove its package-local nicknames everywhere Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Sat Mar 9 05:02:30 2013 (r14428) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Sat Mar 9 05:02:37 2013 (r14429) @@ -178,6 +178,13 @@ } } + LispObject packages = Packages.getPackagesNicknamingPackage(this); + while (packages != NIL) { + Package p = (Package)((Cons)packages).car(); + packages = ((Cons)packages).cdr(); + p.removeLocalPackageNicknamesForPackage(this); + } + Packages.deletePackage(this); makeSymbolsUninterned(internalSymbols); @@ -810,6 +817,19 @@ } } + public void removeLocalPackageNicknamesForPackage(Package p) + { + if (localNicknames == null || !localNicknames.containsValue(p)) { + return; + } else { + for (Map.Entry entry : localNicknames.entrySet()) { + if (entry.getValue() == p) { + localNicknames.remove(entry.getKey()); + } + } + } + } + public Collection getLocallyNicknamedPackages() { // for implementing package-locally-nicknamed-by-list From rschlatte at common-lisp.net Sat Mar 9 13:02:46 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 09 Mar 2013 05:02:46 -0800 Subject: [armedbear-cvs] r14430 - in trunk/abcl: . test/lisp/abcl Message-ID: Author: rschlatte Date: Sat Mar 9 05:02:45 2013 New Revision: 14430 Log: Add tests for package-local nicknames Added: trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd Sat Mar 9 05:02:37 2013 (r14429) +++ trunk/abcl/abcl.asd Sat Mar 9 05:02:45 2013 (r14430) @@ -61,7 +61,9 @@ (:file "zip") #+abcl (:file "pathname-tests" :depends-on - ("utilities")))))) + ("utilities")) + #+abcl + (:file "package-local-nicknames-tests"))))) (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." Added: trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp Sat Mar 9 05:02:45 2013 (r14430) @@ -0,0 +1,181 @@ +;;; package-local-nicknames-tests.lisp +;;; +;;; Copyright (C) 2013 Nikodemus Siivola, Rudolf Schlatte +;;; $Id$ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +;;; Most of these tests are adapted from the SBCL test suite. + +(in-package #:abcl.test.lisp) + +(defmacro with-tmp-packages (bindings &body body) + `(let ,(mapcar #'car bindings) + (unwind-protect + (progn + (setf ,@(apply #'append bindings)) + , at body) + ,@(mapcar (lambda (p) + `(when ,p (delete-package ,p))) + (mapcar #'car bindings))))) + +(defpackage :package-local-nicknames-test-1 + (:local-nicknames (:l :cl) (:e :ext))) + +(defpackage :package-local-nicknames-test-2 + (:export "CONS")) + +(deftest pln-introspect + (let ((alist (ext:package-local-nicknames :package-local-nicknames-test-1))) + (values + (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)) + (equal (cons "E" (find-package "EXT")) (assoc "E" alist :test 'string=)) + (eql 2 (length alist)))) + t + t + t) + +(deftest pln-usage + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cons0 (read-from-string "L:CONS")) + (exit0 (read-from-string "E:EXIT")) + (cons1 (find-symbol "CONS" :l)) + (exit1 (find-symbol "EXIT" :e)) + (cl (find-package :l)) + (ext (find-package :e))) + (values + (eq 'cons cons0) + (eq 'cons cons1) + (equal "L:CONS" (prin1-to-string cons0)) + (eq 'ext:exit exit0) + (eq 'ext:exit exit1) + (equal "E:EXIT" (prin1-to-string exit0)) + (eq cl (find-package :common-lisp)) + (eq ext (find-package :ext))))) + T + T + T + T + T + T + T + T) + +(deftest pln-add-nickname-twice + (handler-case + (ext:add-package-local-nickname :l :package-local-nicknames-test-2 + :package-local-nicknames-test-1) + (error () + :oopsie)) + :oopsie) + +(deftest pln-add-same-nickname + (progn (ext:add-package-local-nickname :l :cl + :package-local-nicknames-test-1) + :okay) + :okay) + +(deftest pln-remove-local-nickname + (progn + (assert (ext:remove-package-local-nickname :l :package-local-nicknames-test-1)) + (assert (not (ext:remove-package-local-nickname :l :package-local-nicknames-test-1))) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((exit0 (read-from-string "E:EXIT")) + (exit1 (find-symbol "EXIT" :e)) + (e (find-package :e))) + (assert (eq 'ext:exit exit0)) + (assert (eq 'ext:exit exit1)) + (assert (equal "E:EXIT" (prin1-to-string exit0))) + (assert (eq e (find-package :ext))) + (assert (not (find-package :l))))) + (assert (eq (find-package :package-local-nicknames-test-1) + (ext:add-package-local-nickname :l :package-local-nicknames-test-2 + :package-local-nicknames-test-1))) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cons0 (read-from-string "L:CONS")) + (exit0 (read-from-string "E:EXIT")) + (cons1 (find-symbol "CONS" :l)) + (exit1 (find-symbol "EXIT" :e)) + (cl (find-package :l)) + (e (find-package :e))) + (assert (eq cons0 cons1)) + (assert (not (eq 'cons cons0))) + (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2) + cons0)) + (assert (equal "L:CONS" (prin1-to-string cons0))) + (assert (eq 'ext:exit exit0)) + (assert (eq 'ext:exit exit1)) + (assert (equal "E:EXIT" (prin1-to-string exit0))) + (assert (eq cl (find-package :package-local-nicknames-test-2))) + (assert (eq e (find-package :ext))))) + :success) + :success) + +(deftest pln-delete-locally-nicknaming-package + (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS")) + (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))) + (ext:add-package-local-nickname :foo p2 p1) + (assert (equal (list p1) (ext:package-locally-nicknamed-by-list p2))) + (delete-package p1) + (assert (null (ext:package-locally-nicknamed-by-list p2))) + :success) + :success) + +(deftest pln-delete-locally-nicknamed-package + (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS")) + (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))) + (ext:add-package-local-nickname :foo p2 p1) + (assert (ext:package-local-nicknames p1)) + (delete-package p2) + (assert (null (ext:package-local-nicknames p1))) + :success) + :success) + +(deftest pln-own-name-as-local-nickname + (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1")) + (p2 (make-package "OWN-NAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1) + (error () + :oops)))) + ;; TODO: add continuable errors for this + ;; (handler-bind ((error #'continue)) + ;; (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)) + ;; (assert (eq (intern "FOO" p2) + ;; (let ((*package* p1)) + ;; (intern "FOO" :own-name-as-nickname1)))) + :success) + :success) + + + +(deftest pln-own-nickname-as-local-nickname + (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1" + :nicknames '("OWN-NICKNAME"))) + (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (add-package-local-nickname :own-nickname p2 p1) + (error () + :oops)))) + ;; TODO: make errors continuable + ;; (handler-bind ((error #'continue)) + ;; (add-package-local-nickname :own-nickname p2 p1)) + ;; (assert (eq (intern "FOO" p2) + ;; (let ((*package* p1)) + ;; (intern "FOO" :own-nickname)))) + :success) + :success) From rschlatte at common-lisp.net Sun Mar 10 15:52:42 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 10 Mar 2013 08:52:42 -0700 Subject: [armedbear-cvs] r14431 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: rschlatte Date: Sun Mar 10 08:52:36 2013 New Revision: 14431 Log: Make add-package-local-nicknames errors continuable - partly fixes #307 Modified: trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/package.lisp trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Sat Mar 9 05:02:45 2013 (r14430) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Sun Mar 10 08:52:36 2013 (r14431) @@ -780,16 +780,6 @@ 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 != null && 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(); } Modified: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Sat Mar 9 05:02:45 2013 (r14430) +++ trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Sun Mar 10 08:52:36 2013 (r14431) @@ -285,7 +285,7 @@ // ### 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, + new Primitive("%add-package-local-nickname", PACKAGE_SYS, false, "local-nickname package &optional package-designator") { @Override Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Mar 9 05:02:45 2013 (r14430) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Mar 10 08:52:36 2013 (r14431) @@ -2968,6 +2968,8 @@ PACKAGE_EXT.addExternalSymbol("URL-PATHNAME"); public static final Symbol WEAK_REFERENCE = PACKAGE_EXT.addExternalSymbol("WEAK-REFERENCE"); + public static final Symbol ADD_PACKAGE_LOCAL_NICKNAME = + PACKAGE_EXT.addExternalSymbol("ADD-PACKAGE-LOCAL-NICKNAME"); // MOP. public static final Symbol CLASS_LAYOUT = Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/package.lisp Sat Mar 9 05:02:45 2013 (r14430) +++ trunk/abcl/src/org/armedbear/lisp/package.lisp Sun Mar 10 08:52:36 2013 (r14431) @@ -96,3 +96,24 @@ (defun delete-package (package) (with-simple-restart (continue "Ignore missing package.") (sys::%delete-package package))) + +(defun add-package-local-nickname (local-nickname actual-package + &optional (package-designator *package*)) + (let* ((local-nickname (string local-nickname)) + (package-designator (or (find-package package-designator) + (error "Package ~A not found" package-designator))) + (actual-package (or (find-package actual-package) + (error "Package ~A not found" actual-package)))) + (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD") + :test #'string=) + (cerror "Continue anyway" + "Trying to define a local nickname called ~A" local-nickname)) + (when (member local-nickname (list* (package-name package-designator) + (package-nicknames package-designator)) + :test #'string=) + (cerror "Continue anyway" + "Trying to override the name or nickname ~A for package ~A ~ + with a local nickname for another package ~A" + local-nickname package-designator actual-package)) + (sys::%add-package-local-nickname local-nickname actual-package + package-designator))) Modified: trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp Sat Mar 9 05:02:45 2013 (r14430) +++ trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp Sun Mar 10 08:52:36 2013 (r14431) @@ -151,31 +151,29 @@ (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1) (error () :oops)))) - ;; TODO: add continuable errors for this - ;; (handler-bind ((error #'continue)) - ;; (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)) - ;; (assert (eq (intern "FOO" p2) - ;; (let ((*package* p1)) - ;; (intern "FOO" :own-name-as-nickname1)))) + (handler-bind ((error #'continue)) + (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)) + (assert (eq (intern "FOO" p2) + (let ((*package* p1)) + (intern "FOO" :own-name-as-nickname1)))) :success) :success) (deftest pln-own-nickname-as-local-nickname - (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1" - :nicknames '("OWN-NICKNAME"))) - (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2"))) - (assert (eq :oops - (handler-case - (add-package-local-nickname :own-nickname p2 p1) - (error () - :oops)))) - ;; TODO: make errors continuable - ;; (handler-bind ((error #'continue)) - ;; (add-package-local-nickname :own-nickname p2 p1)) - ;; (assert (eq (intern "FOO" p2) - ;; (let ((*package* p1)) - ;; (intern "FOO" :own-nickname)))) - :success) + (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1" + :nicknames '("OWN-NICKNAME"))) + (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (ext:add-package-local-nickname :own-nickname p2 p1) + (error () + :oops)))) + (handler-bind ((error #'continue)) + (ext:add-package-local-nickname :own-nickname p2 p1)) + (assert (eq (intern "FOO" p2) + (let ((*package* p1)) + (intern "FOO" :own-nickname)))) + :success) :success) From rschlatte at common-lisp.net Sun Mar 10 16:07:43 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 10 Mar 2013 09:07:43 -0700 Subject: [armedbear-cvs] r14432 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Mar 10 09:07:43 2013 New Revision: 14432 Log: Some more package-local-nickname error checking in defpackage Modified: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Modified: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Sun Mar 10 08:52:36 2013 (r14431) +++ trunk/abcl/src/org/armedbear/lisp/defpackage.lisp Sun Mar 10 09:07:43 2013 (r14432) @@ -129,14 +129,20 @@ (unless (= (length nickdecl) 2) (error 'program-error "Malformed local nickname declaration ~A" nickdecl)) - (let ((nickname (string (first nickdecl))) + (let ((local-nickname (string (first nickdecl))) (package-name (designated-package-name (second nickdecl)))) - (when (member nickname '("CL" "COMMON-LISP" "KEYWORD") - :test #'string-equal) + (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD") + :test #'string=) (cerror "Continue anyway" (format nil "Trying to define a local nickname for package ~A" - package-name))) - (push (list nickname package-name) local-nicknames)))) + local-nickname))) + (when (member local-nickname (list* package nicknames) + :test #'string=) + (cerror "Continue anyway" + "Trying to override the name or a nickname (~A) ~ + with a local nickname for another package ~A" + local-nickname package-name)) + (push (list local-nickname package-name) local-nicknames)))) (t (error 'program-error "bad DEFPACKAGE option: ~S" option)))) (check-disjoint `(:intern , at interns) `(:export , at exports)) From mevenson at common-lisp.net Tue Mar 12 13:19:54 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 12 Mar 2013 06:19:54 -0700 Subject: [armedbear-cvs] r14433 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Mar 12 06:19:53 2013 New Revision: 14433 Log: Ensure that the pretty printer has been loaded before Gray streams. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Sun Mar 10 09:07:43 2013 (r14432) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Tue Mar 12 06:19:53 2013 (r14433) @@ -114,6 +114,8 @@ ;;;; Much of the implementation of the Gray streams below is from the ;;;; document referenced earlier. ;;;; +(require "PPRINT") + (defpackage "GRAY-STREAMS" (:use "COMMON-LISP") From mevenson at common-lisp.net Tue Mar 12 13:19:55 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 12 Mar 2013 06:19:55 -0700 Subject: [armedbear-cvs] r14434 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Mar 12 06:19:54 2013 New Revision: 14434 Log: Allow "simple" FORMAT invocations on types derived from Gray streams. With this patch, calls like (format GRAY-STREAM "42") will work on streams derived from Gray streams (like FLEXI-STREAMS). Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Tue Mar 12 06:19:53 2013 (r14433) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Tue Mar 12 06:19:54 2013 (r14434) @@ -649,3 +649,21 @@ |# (provide 'gray-streams) + +;;; Fixup Gray/ANSI stream relations + +(defparameter *sys--stream-charpos* #'sys::stream-charpos) +(defun sys::stream-charpos (stream) + (cond + ((subtypep (type-of stream) 'gray-streams:fundamental-stream) + (stream-line-column stream)) + ((streamp stream) + (funcall *sys--stream-charpos* stream)))) + +(defparameter *sys--stream-%set-charpos* #'sys::stream-%set-charpos) +(defun sys::stream-%set-charpos (new-value stream) + (cond + ((subtypep (type-of stream) 'gray-streams:fundamental-stream) + (setf (stream-line-column stream) new-value)) + ((streamp stream) + (sys::stream-%set-charpos stream new-value)))) From mevenson at common-lisp.net Tue Mar 12 13:19:59 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 12 Mar 2013 06:19:59 -0700 Subject: [armedbear-cvs] r14435 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Mar 12 06:19:56 2013 New Revision: 14435 Log: Explicitly finalize inheritance for classes in GRAY-STREAMS. Fixes #300. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Tue Mar 12 06:19:54 2013 (r14434) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Tue Mar 12 06:19:56 2013 (r14435) @@ -648,6 +648,15 @@ (setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream) |# +(eval-when (:load-toplevel) + (mapcar (lambda (o) (mop:finalize-inheritance (find-class o))) + '(fundamental-stream + fundamental-input-stream fundamental-output-stream + fundamental-character-stream + fundamental-character-input-stream fundamental-character-output-stream + fundamental-binary-stream + fundamental-binary-input-stream fundamental-binary-output-stream))) + (provide 'gray-streams) ;;; Fixup Gray/ANSI stream relations From rschlatte at common-lisp.net Wed Mar 13 09:34:40 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 13 Mar 2013 02:34:40 -0700 Subject: [armedbear-cvs] r14436 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 13 02:34:28 2013 New Revision: 14436 Log: Fix potential endless loop in sys::stream-%set-charpos Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Tue Mar 12 06:19:56 2013 (r14435) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Wed Mar 13 02:34:28 2013 (r14436) @@ -675,4 +675,4 @@ ((subtypep (type-of stream) 'gray-streams:fundamental-stream) (setf (stream-line-column stream) new-value)) ((streamp stream) - (sys::stream-%set-charpos stream new-value)))) + (funcall *sys--stream-%set-charpos* stream new-value)))) From mevenson at common-lisp.net Wed Mar 20 08:50:30 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 20 Mar 2013 01:50:30 -0700 Subject: [armedbear-cvs] r14437 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Wed Mar 20 01:50:29 2013 New Revision: 14437 Log: Correct the jars on the filesytem example in abcl-asdf README. Modified: trunk/abcl/contrib/abcl-asdf/README.markdown Modified: trunk/abcl/contrib/abcl-asdf/README.markdown ============================================================================== --- trunk/abcl/contrib/abcl-asdf/README.markdown Wed Mar 13 02:34:28 2013 (r14436) +++ trunk/abcl/contrib/abcl-asdf/README.markdown Wed Mar 20 01:50:29 2013 (r14437) @@ -138,7 +138,7 @@ (defsystem :wsml2reasoner-jars :version "0.6.4" ;; last sync with SVN - :depends-on (:abcld) :components + :defsystem-depends-on (abcl-contrib abcl-asdf) :components ((:module wsml2reasoner :pathname "lib/" :components ((:jar-file "wsml2reasoner"))) @@ -164,5 +164,5 @@ Mark Created: 2011-01-01 - Revised: 2012-12-06 + Revised: 2013-03-20 From mevenson at common-lisp.net Thu Mar 21 14:13:28 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 21 Mar 2013 07:13:28 -0700 Subject: [armedbear-cvs] r14438 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Thu Mar 21 07:13:27 2013 New Revision: 14438 Log: Fix JSS:VECTOR-TO-LIST and JSS:ITERABLE-TO-LIST. Found by zmyrgel on #abcl. Modified: trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Wed Mar 20 01:50:29 2013 (r14437) +++ trunk/abcl/contrib/jss/invoke.lisp Thu Mar 21 07:13:27 2013 (r14438) @@ -567,17 +567,19 @@ "Return the items contained the java.lang.Iterable ITERABLE as a list." (declare (optimize (speed 3) (safety 0))) (let ((it (#"iterator" iterable))) - (with-constant-signature ((hasmore "hasMoreElements") - (next "nextElement")) - (loop while (hasmore it) - collect (next it))))) + (with-constant-signature ((has-next "hasNext") + (next "next")) + (loop :while (has-next it) + :collect (next it))))) (defun vector-to-list (vector) + "Return the elements of java.lang.Vector VECTOR as a list." (declare (optimize (speed 3) (safety 0))) - (with-constant-signature ((hasmore "hasMoreElements") + (with-constant-signature ((has-more "hasMoreElements") (next "nextElement")) - (loop while (hasmore vector) - collect (next vector)))) + (let ((elements (#"elements" vector))) + (loop :while (has-more elements) + :collect (next elements))))) (defun hashmap-to-hashtable (hashmap &rest rest &key (keyfun #'identity) (valfun #'identity) (invert? nil) table Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Wed Mar 20 01:50:29 2013 (r14437) +++ trunk/abcl/contrib/jss/jss.asd Thu Mar 21 07:13:27 2013 (r14438) @@ -1,8 +1,8 @@ ;;;; -*- Mode: LISP -*- (asdf:defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "3.0.5" - :description "<> asdf:defsystem asdf:defsystem Author: mevenson Date: Thu Mar 21 07:52:42 2013 New Revision: 14439 Log: Restore loading of ASDF-JAR. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.asd Thu Mar 21 07:13:27 2013 (r14438) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.asd Thu Mar 21 07:52:42 2013 (r14439) @@ -4,7 +4,7 @@ (defsystem :asdf-jar :author "Mark Evenson" :version "0.2.1" - :description "<> asdf:defsystem + :description "<> asdf:defsystem " :components ((:module base :pathname "" :components ((:file "asdf-jar") From mevenson at common-lisp.net Thu Mar 21 19:33:23 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 21 Mar 2013 12:33:23 -0700 Subject: [armedbear-cvs] r14440 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Thu Mar 21 12:33:22 2013 New Revision: 14440 Log: Restore ASDF-JAR:PACKAGE. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Mar 21 07:52:42 2013 (r14439) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Mar 21 12:33:22 2013 (r14440) @@ -82,7 +82,7 @@ (defun all-files (component) (loop :for c - :being :each :hash-value :of (slot-value component 'asdf::components-by-name) + :being :each :hash-value :of (slot-value component 'asdf::children-by-name) :when (typep c 'asdf:module) :append (all-files c) :when (typep c 'asdf:source-file) From ehuelsmann at common-lisp.net Fri Mar 22 20:09:42 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 22 Mar 2013 13:09:42 -0700 Subject: [armedbear-cvs] r14441 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 22 13:09:41 2013 New Revision: 14441 Log: Stop modifying form structure in pass1. Note: it's bad style to modify borrowed data. Also, we can't know for sure there's no structure sharing somewhere. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Mar 21 12:33:22 2013 (r14440) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Mar 22 13:09:41 2013 (r14441) @@ -444,19 +444,13 @@ (declaim (ftype (function (t) t) p1-body)) (defun p1-body (body) (declare (optimize speed)) - (let ((tail body)) - (loop - (when (endp tail) - (return)) - (setf (car tail) (p1 (%car tail))) - (setf tail (%cdr tail)))) - body) + (loop for form in body + collect (p1 form))) (defknown p1-default (t) t) (declaim (inline p1-default)) (defun p1-default (form) - (setf (cdr form) (p1-body (cdr form))) - form) + (cons (car form) (p1-body (cdr form)))) (defmacro p1-let/let*-vars (block varlist variables-var var body1 body2) @@ -605,8 +599,8 @@ (defun p1-block (form) (let* ((block (make-block-node (cadr form))) (*block* block) - (*blocks* (cons block *blocks*))) - (setf (cddr form) (p1-body (cddr form))) + (*blocks* (cons block *blocks*)) + (form (list* (car form) (cadr form) (p1-body (cddr form))))) (setf (block-form block) form) (when (block-non-local-return-p block) ;; Add a closure variable for RETURN-FROM to use From mevenson at common-lisp.net Fri Mar 22 23:05:31 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 22 Mar 2013 16:05:31 -0700 Subject: [armedbear-cvs] r14442 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Mar 22 16:05:30 2013 New Revision: 14442 Log: Document types for compiler diagnostic callbacks pushed to JVM:*CALLBACKS* Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Mar 22 13:09:41 2013 (r14441) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Mar 22 16:05:30 2013 (r14442) @@ -40,7 +40,10 @@ (defvar *enable-dformat* nil) (defvar *callbacks* nil "A list of functions to be called by the compiler and code generator -in order to generate 'compilation events'.") +in order to generate 'compilation events'. + +A callback function takes five arguments: +CALLBACK-TYPE CLASS PARENT CONTENT EXCEPTION-HANDLERS.") (declaim (inline invoke-callbacks)) (defun invoke-callbacks (&rest args) From ehuelsmann at common-lisp.net Sat Mar 23 00:02:21 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 22 Mar 2013 17:02:21 -0700 Subject: [armedbear-cvs] r14443 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 22 17:02:10 2013 New Revision: 14443 Log: Take advantage of PRINT-OBJECT functions having been defined to create (humanly) readable output for complex data structures. Modified: trunk/abcl/src/org/armedbear/lisp/trace.lisp Modified: trunk/abcl/src/org/armedbear/lisp/trace.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/trace.lisp Fri Mar 22 16:05:30 2013 (r14442) +++ trunk/abcl/src/org/armedbear/lisp/trace.lisp Fri Mar 22 17:02:10 2013 (r14443) @@ -84,7 +84,7 @@ (with-standard-io-syntax (let ((*print-readably* nil) (*print-structure* nil)) - (%format *trace-output* (indent "~D: ~S~%") *trace-depth* + (format *trace-output* (indent "~D: ~S~%") *trace-depth* (cons name args)))) (when breakp (break)) @@ -96,11 +96,11 @@ (with-standard-io-syntax (let ((*print-readably* nil) (*print-structure* nil)) - (%format *trace-output* (indent "~D: ~A returned") *trace-depth* name) + (format *trace-output* (indent "~D: ~A returned") *trace-depth* name) (if results (dolist (result results) - (%format *trace-output* " ~S" result)) - (%format *trace-output* " no values")) + (format *trace-output* " ~S" result)) + (format *trace-output* " no values")) (terpri *trace-output*))) (values-list results))))) From ehuelsmann at common-lisp.net Sat Mar 23 00:03:47 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 22 Mar 2013 17:03:47 -0700 Subject: [armedbear-cvs] r14444 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 22 17:03:38 2013 New Revision: 14444 Log: Add print methods for compiler structures I'm trying to debug. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Mar 22 17:02:10 2013 (r14443) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Mar 22 17:03:38 2013 (r14444) @@ -269,6 +269,15 @@ (compiland *current-compiland*) block) + +(defmethod print-object ((object jvm::variable-info) stream) + (print-unreadable-object (object stream :type t :identity t) + (princ (jvm::variable-name object) stream) + (princ " in " stream) + (princ (jvm::compiland-name (jvm::variable-compiland object)) stream))) + + + (defstruct (var-ref (:constructor make-var-ref (variable))) ;; The variable this reference refers to. Will be NIL if the VAR-REF has been ;; rewritten to reference a constant value. @@ -278,6 +287,11 @@ ;; The constant value of this VAR-REF. constant-value) +(defmethod print-object ((object jvm::var-ref) stream) + (print-unreadable-object (object stream :type t :identity t) + (princ "ref ") + (print-object (jvm::var-ref-variable object) stream))) + ;; obj can be a symbol or variable ;; returns variable or nil (declaim (ftype (function (t) t) unboxed-fixnum-variable)) From ehuelsmann at common-lisp.net Sat Mar 23 01:25:31 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 22 Mar 2013 18:25:31 -0700 Subject: [armedbear-cvs] r14445 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 22 18:25:29 2013 New Revision: 14445 Log: Re #200: Rewrite form-modifying macro into a series of functional-style functions which return a modified copy instead. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Mar 22 17:03:38 2013 (r14444) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Mar 22 18:25:29 2013 (r14445) @@ -452,54 +452,48 @@ (defun p1-default (form) (cons (car form) (p1-body (cdr form)))) -(defmacro p1-let/let*-vars - (block varlist variables-var var body1 body2) - (let ((varspec (gensym)) - (initform (gensym)) - (name (gensym))) - `(let ((,variables-var ())) - (dolist (,varspec ,varlist) - (cond ((consp ,varspec) - ;; Even though the precompiler already signals this - ;; error, double checking can't hurt; after all, we're - ;; also rewriting &AUX into LET* bindings. - (unless (<= 1 (length ,varspec) 2) - (compiler-error "The LET/LET* binding specification ~S is invalid." - ,varspec)) - (let* ((,name (%car ,varspec)) - (,initform (p1 (%cadr ,varspec))) - (,var (make-variable :name (check-name ,name) - :initform ,initform - :block ,block))) - (when (neq ,initform (cadr ,varspec)) - (setf (cadr ,varspec) ,initform)) - (push ,var ,variables-var) - , at body1)) - (t - (let ((,var (make-variable :name (check-name ,varspec) - :block ,block))) - (push ,var ,variables-var) - , at body1)))) - , at body2))) +(defun let/let*-variables (block bindings) + (loop for binding in bindings + if (consp binding) + collect (make-variable :name (check-name (car binding)) + :initform (cadr binding) + :block block) + else + collect (make-variable :name (check-name binding) + :block block))) + +(defun valid-let/let*-binding-p (varspec) + (when (consp varspec) + (unless (<= 1 (length varspec) 2) + (compiler-error "The LET/LET* binding specification ~ + ~S is invalid." varspec))) + T) + +(defun check-let/let*-bindings (bindings) + (every #'valid-let/let*-binding-p bindings)) (defknown p1-let-vars (t) t) (defun p1-let-vars (block varlist) - (p1-let/let*-vars block - varlist vars var - () - ((setf vars (nreverse vars)) + (check-let/let*-bindings varlist) + (let ((vars (let/let*-variables block varlist))) + (dolist (variable vars) + (setf (variable-initform variable) + (p1 (variable-initform variable)))) (dolist (variable vars) (push variable *visible-variables*) (push variable *all-variables*)) - vars))) + vars)) (defknown p1-let*-vars (t) t) (defun p1-let*-vars (block varlist) - (p1-let/let*-vars block - varlist vars var - ((push var *visible-variables*) - (push var *all-variables*)) - ((nreverse vars)))) + (check-let/let*-bindings varlist) + (let ((vars (let/let*-variables block varlist))) + (dolist (variable vars) + (setf (variable-initform variable) + (p1 (variable-initform variable))) + (push variable *visible-variables*) + (push variable *all-variables*)) + vars)) (defun p1-let/let* (form) (declare (type cons form)) From rschlatte at common-lisp.net Sun Mar 24 18:17:29 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 24 Mar 2013 11:17:29 -0700 Subject: [armedbear-cvs] r14446 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Mar 24 11:17:28 2013 New Revision: 14446 Log: Fix %allocate-funcallable-instance for non-gf funcallable objects - For subclasses of standard-generic-function, return a StandardGenericFunction object; otherwise, create a plain FuncallableStandardObject. - Fixes crash while compiling cl-l10n Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Fri Mar 22 18:25:29 2013 (r14445) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Sun Mar 24 11:17:28 2013 (r14446) @@ -188,10 +188,11 @@ if (! (l instanceof Layout)) { return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); } - // KLUDGE (rudi 2012-03-17): make (make-instance - // 'standard-generic-function) work -- subsequent code expects - // the additional slots to be present. - return new StandardGenericFunction((Layout)l); + if (Symbol.SUBTYPEP.execute(arg, StandardClass.STANDARD_GENERIC_FUNCTION) != NIL) { + return new StandardGenericFunction((Layout)l); + } else { + return new FuncallableStandardObject((Layout)l); + } } return type_error(arg, Symbol.FUNCALLABLE_STANDARD_CLASS); } From ehuelsmann at common-lisp.net Sun Mar 24 19:15:28 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 24 Mar 2013 12:15:28 -0700 Subject: [armedbear-cvs] r14447 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 24 12:15:26 2013 New Revision: 14447 Log: Re #230: Add a macro expansion for TRULY-THE. Modified: trunk/abcl/src/org/armedbear/lisp/macros.lisp Modified: trunk/abcl/src/org/armedbear/lisp/macros.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/macros.lisp Sun Mar 24 11:17:28 2013 (r14446) +++ trunk/abcl/src/org/armedbear/lisp/macros.lisp Sun Mar 24 12:15:26 2013 (r14447) @@ -55,6 +55,9 @@ (defmacro defparameter (name initial-value &optional docstring) `(%defparameter ',name ,initial-value ,docstring)) +(defmacro truly-the (type value) + `(the ,type ,value)) + (defmacro %car (x) `(car (truly-the cons ,x))) From rschlatte at common-lisp.net Wed Mar 27 10:30:01 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 27 Mar 2013 03:30:01 -0700 Subject: [armedbear-cvs] r14448 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 27 03:29:58 2013 New Revision: 14448 Log: Remove most references to StandardGenericFunction - use TYPEP or "instanceof FuncallableStandardObject" instead Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Profiler.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Mar 24 12:15:26 2013 (r14447) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Mar 27 03:29:58 2013 (r14448) @@ -1809,7 +1809,7 @@ { if (obj instanceof Function) return obj; - if (obj instanceof StandardGenericFunction) + if (obj instanceof FuncallableStandardObject) return obj; if (obj instanceof Symbol) { Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Mar 24 12:15:26 2013 (r14447) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Wed Mar 27 03:29:58 2013 (r14448) @@ -670,10 +670,8 @@ SimpleString doc = new SimpleString(docstring); ((Symbol)this).setDocumentation(Symbol.FUNCTION, doc); return doc; - } else if (fn instanceof StandardGenericFunction) { - return - StandardGenericFunction.checkStandardGenericFunction(fn) - .slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]; + } else if (fn.typep(StandardClass.STANDARD_GENERIC_FUNCTION) != NIL) { + return Symbol.SLOT_VALUE.execute(fn, Symbol._DOCUMENTATION); } } } Modified: trunk/abcl/src/org/armedbear/lisp/Profiler.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Profiler.java Sun Mar 24 12:15:26 2013 (r14447) +++ trunk/abcl/src/org/armedbear/lisp/Profiler.java Wed Mar 27 03:29:58 2013 (r14448) @@ -72,7 +72,7 @@ object.setCallCount(0); object.setHotCount(0); LispObject methods = null; - if (object instanceof StandardGenericFunction) { + if (object.typep(StandardClass.STANDARD_GENERIC_FUNCTION) != NIL) { methods = Symbol.GENERIC_FUNCTION_METHODS.execute(object); } Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java Sun Mar 24 12:15:26 2013 (r14447) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Wed Mar 27 03:29:58 2013 (r14448) @@ -415,7 +415,7 @@ char c = LispCharacter.getValue(first); final LispObject designator; if (second instanceof Function - || second instanceof StandardGenericFunction) + || second instanceof FuncallableStandardObject) designator = second; else if (second instanceof Symbol) designator = second; Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Sun Mar 24 12:15:26 2013 (r14447) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Wed Mar 27 03:29:58 2013 (r14448) @@ -469,7 +469,7 @@ } if (operator instanceof Function) return operator; - if (operator instanceof StandardGenericFunction) + if (operator instanceof FuncallableStandardObject) return operator; return error(new UndefinedFunction(arg)); } From mevenson at common-lisp.net Wed Mar 27 14:07:08 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 27 Mar 2013 07:07:08 -0700 Subject: [armedbear-cvs] r14449 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Mar 27 07:07:05 2013 New Revision: 14449 Log: Fix UNEXPORT to work on symbols from foreign packages. No longer check that the symbols which are the target of UNEXPORT are accessible. Such symbols may be present in a foreign package as they may have been part of a USE clause for which the original symbol has subsequently made internal in its home package by a previous UNEXPORT operation. Fixes #311. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Wed Mar 27 03:29:58 2013 (r14448) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Wed Mar 27 07:07:05 2013 (r14449) @@ -560,28 +560,16 @@ public synchronized void unexport(final Symbol symbol) { - if (symbol.getPackage() == this) { - if (externalSymbols.get(symbol.name.toString()) == symbol) { - externalSymbols.remove(symbol.name.toString()); - internalSymbols.put(symbol.name.toString(), symbol); - } - } else { - // Signal an error if symbol is not accessible. - if (useList instanceof Cons) { - LispObject usedPackages = useList; - while (usedPackages != NIL) { - Package pkg = (Package) usedPackages.car(); - if (pkg.findExternalSymbol(symbol.name) == symbol) - return; // OK. - usedPackages = usedPackages.cdr(); - } - } - StringBuilder sb = new StringBuilder("The symbol "); - sb.append(symbol.getQualifiedName()); - sb.append(" is not accessible in package "); - sb.append(name); - error(new PackageError(sb.toString())); - } + if (externalSymbols.get(symbol.name.toString()) == symbol) { + externalSymbols.remove(symbol.name.toString()); + internalSymbols.put(symbol.name.toString(), symbol); + } else if (!(internalSymbols.get(symbol.name.toString()) == symbol)) { + StringBuilder sb = new StringBuilder("The symbol "); + sb.append(symbol.getQualifiedName()); + sb.append(" is not accessible in package "); + sb.append(name); + error(new PackageError(sb.toString())); + } } public synchronized void shadow(final String symbolName) Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Wed Mar 27 03:29:58 2013 (r14448) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Wed Mar 27 07:07:05 2013 (r14449) @@ -141,3 +141,21 @@ '(a .?0)) (A . #\Null)) +;;; http://trac.common-lisp.net/armedbear/ticket/311 +(deftest bugs.export.1 + (let ((a (symbol-name (gensym "PACKAGE-"))) + (b (symbol-name (gensym "PACKAGE-"))) + result) + (make-package a) + (intern "FOO" a) + (export (find-symbol "FOO" a) a) + (make-package b :use (list a)) + (export (find-symbol "FOO" b) b) + (unexport (find-symbol "FOO" a) a) + (setf result (unexport (find-symbol "FOO" b) b)) + (delete-package a) + (delete-package b) + result) + t) + + From mevenson at common-lisp.net Wed Mar 27 14:35:17 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 27 Mar 2013 07:35:17 -0700 Subject: [armedbear-cvs] r14450 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Wed Mar 27 07:35:16 2013 New Revision: 14450 Log: Update the URL-PATHNAME archive to fasl version 40. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Mar 27 07:07:05 2013 (r14449) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Mar 27 07:35:16 2013 (r14450) @@ -202,7 +202,7 @@ t) (defparameter *url-jar-pathname-base* - "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20120514a.jar!/") + "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20130327a.jar!/") (defmacro load-url-relative (path) `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) @@ -498,4 +498,4 @@ (let ((*default-pathname-defaults* jar-entry-dir)) (not (probe-file (merge-pathnames jar-entry))))) nil) - \ No newline at end of file + From mevenson at common-lisp.net Wed Mar 27 14:35:18 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 27 Mar 2013 07:35:18 -0700 Subject: [armedbear-cvs] r14451 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Mar 27 07:35:18 2013 New Revision: 14451 Log: Loosen check for issuing redfinition from TRUENAME to PROBE-FILENAME. Under no condition should we be promoting what should be a warning to an error if the truename fails. In any event, the function redefinition check still has corner cases, for example when used with JAR-PATHNAME, that need to be (eventually) nailed down. Modified: trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp Modified: trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp Wed Mar 27 07:35:16 2013 (r14450) +++ trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp Wed Mar 27 07:35:18 2013 (r14451) @@ -37,14 +37,16 @@ (when (and *warn-on-redefinition* (fboundp name) (not (autoloadp name))) (when (and (symbolp name) (source-pathname name)) + ;; SOURCE-PATHNAME is badly named as it is either a PATHNAMAE + ;; or the symbol :TOP-LEVEL (let ((old-source (if (keywordp (source-pathname name)) (source-pathname name) - (truename (source-pathname name)))) + (probe-file (source-pathname name)))) (current-source (if (not *source*) :top-level - (truename *source*)))) + (probe-file *source*)))) (cond ((equal old-source current-source)) ; OK (t From ehuelsmann at common-lisp.net Fri Mar 29 21:19:22 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 29 Mar 2013 14:19:22 -0700 Subject: [armedbear-cvs] r14452 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 29 14:19:19 2013 New Revision: 14452 Log: Fix cl-cont, which causes %SET-LAMBDA-NAME to be called on a FUNCALLABLE-INSTANCE, which until now didn't support that. This commit moves the use of the NAME slot from STANDARD-GENERIC-FUNCTION to FUNCALLABLE-INSTANCE. Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardClass.java trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardClass.java Wed Mar 27 07:35:18 2013 (r14451) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardClass.java Fri Mar 29 14:19:19 2013 (r14452) @@ -37,6 +37,7 @@ public class FuncallableStandardClass extends StandardClass { + public static final int SLOT_INDEX_NAME = 0; public FuncallableStandardClass() { Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Wed Mar 27 07:35:18 2013 (r14451) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Fri Mar 29 14:19:19 2013 (r14452) @@ -42,6 +42,9 @@ { protected LispObject function; + public static int SLOT_INDEX_NAME = 1; + + protected FuncallableStandardObject() { super(); @@ -86,6 +89,17 @@ return super.typep(type); } + public LispObject getName() + { + return slots[FuncallableStandardClass.SLOT_INDEX_NAME]; + } + + public void setName(LispObject name) + { + slots[FuncallableStandardClass.SLOT_INDEX_NAME] = name; + } + + @Override public LispObject execute() { Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed Mar 27 07:35:18 2013 (r14451) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Mar 29 14:19:19 2013 (r14452) @@ -2658,10 +2658,10 @@ value1 = NIL; value2 = T; value3 = ((Function)arg).getLambdaName(); - } else if (arg instanceof StandardGenericFunction) { + } else if (arg instanceof FuncallableStandardObject) { value1 = NIL; value2 = T; - value3 = ((StandardGenericFunction)arg).getGenericFunctionName(); + value3 = ((FuncallableStandardObject)arg).getName(); } else return type_error(arg, Symbol.FUNCTION); return LispThread.currentThread().setValues(value1, value2, value3); @@ -4218,8 +4218,8 @@ if (arg instanceof Operator) { return ((Operator)arg).getLambdaName(); } - if (arg instanceof StandardGenericFunction) { - return ((StandardGenericFunction)arg).getGenericFunctionName(); + if (arg instanceof FuncallableStandardObject) { + return ((FuncallableStandardObject)arg).getName(); } return type_error(arg, Symbol.FUNCTION); } @@ -4240,8 +4240,8 @@ ((Operator)first).setLambdaName(second); return second; } - if (first instanceof StandardGenericFunction) { - ((StandardGenericFunction)first).setGenericFunctionName(second); + if (first instanceof FuncallableStandardObject) { + ((FuncallableStandardObject)first).setName(second); return second; } return type_error(first, Symbol.FUNCTION); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Wed Mar 27 07:35:18 2013 (r14451) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Mar 29 14:19:19 2013 (r14452) @@ -91,20 +91,10 @@ return super.typep(type); } - public LispObject getGenericFunctionName() - { - return slots[StandardGenericFunctionClass.SLOT_INDEX_NAME]; - } - - public void setGenericFunctionName(LispObject name) - { - slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = name; - } - @Override public String printObject() { - LispObject name = getGenericFunctionName(); + LispObject name = getName(); if (name != null) { StringBuilder sb = new StringBuilder(); From ehuelsmann at common-lisp.net Fri Mar 29 23:01:38 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 29 Mar 2013 16:01:38 -0700 Subject: [armedbear-cvs] r14453 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 29 16:01:36 2013 New Revision: 14453 Log: Fix recent TINAA-TEST loader crash (regression from FAILure) as detected by cl-test-grid. Note, the failure is caused by the move of the threading primitives to the THREADS package to which KMRCL hasn't been adapted yet. This commit restores back to the FAIL state. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Fri Mar 29 14:19:19 2013 (r14452) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Fri Mar 29 16:01:36 2013 (r14453) @@ -468,13 +468,18 @@ } } // Reaching here, it's OK to remove the symbol. - if (internalSymbols.get(symbol.name.toString()) == symbol) - internalSymbols.remove(symbol.name.toString()); - else if (externalSymbols.get(symbol.name.toString()) == symbol) + boolean found = false; + if (externalSymbols.get(symbol.name.toString()) == symbol) { externalSymbols.remove(symbol.name.toString()); - else - // Not found. + found = true; + } + if (internalSymbols.get(symbol.name.toString()) == symbol) { + internalSymbols.remove(symbol.name.toString()); + found = true; + } + if (! found) return NIL; + if (shadow) { Debug.assertTrue(shadowingSymbols != null); shadowingSymbols.remove(symbolName);