[armedbear-cvs] r12807 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu Jul 15 22:06:44 UTC 2010
Author: ehuelsmann
Date: Thu Jul 15 18:06:43 2010
New Revision: 12807
Log:
Backport r12796-12805 from trunk.
Reduces the current 37 ANSI failures to 34.
Modified:
branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java
branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp
branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java Thu Jul 15 18:06:43 2010
@@ -150,6 +150,7 @@
}
};
+ // ### make-classloader &optional parent => java-class-loader
private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader();
private static final class pf_make_classloader extends Primitive
{
@@ -169,6 +170,7 @@
}
};
+ // ### dump-classpath &optional classloader => list-of-pathname-lists
private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath();
private static final class pf_dump_classpath extends Primitive
{
@@ -195,6 +197,7 @@
}
};
+ // ### add-to-classpath jar-or-jars &optional (classloader (get-current-classloader))
private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath();
private static final class pf_add_to_classpath extends Primitive
{
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java Thu Jul 15 18:06:43 2010
@@ -61,7 +61,7 @@
// A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST.
protected LispObject version = NIL;
- private String namestring;
+ private volatile String namestring;
/** The protocol for changing any instance field (i.e. 'host', 'type', etc.)
* is to call this method after changing the field to recompute the namestring.
@@ -242,7 +242,7 @@
return;
}
if (Utilities.isPlatformWindows) {
- if (s.startsWith("\\\\")) {
+ if (s.startsWith("\\\\")) { // XXX What if string starts with '//'?
//UNC path support
// match \\<server>\<share>\[directories-and-files]
@@ -401,24 +401,9 @@
}
if (Utilities.isPlatformWindows) {
- if (!s.contains(jarSeparator)) {
- s = s.replace("/", "\\");
- } else {
- StringBuilder result = new StringBuilder();
- for (int i = 0; i < s.length(); i++) {
- char c = s.charAt(i);
- if ( c != '/') {
- result.append(c);
- } else {
- if (i != 0 && s.charAt(i-1) != '!') {
- result.append("\\");
- } else {
- result.append(c);
- }
- }
- }
- s = result.toString();
- }
+ if (s.contains("\\")) {
+ s = s.replace("\\", "/");
+ }
}
// Expand user home directories
@@ -438,22 +423,11 @@
}
String d = null;
// Find last file separator char.
- if (Utilities.isPlatformWindows) {
- for (int i = s.length(); i-- > 0;) {
- char c = s.charAt(i);
- if (c == '/' || c == '\\') {
- d = s.substring(0, i + 1);
- s = s.substring(i + 1);
- break;
- }
- }
- } else {
- for (int i = s.length(); i-- > 0;) {
- if (s.charAt(i) == '/') {
- d = s.substring(0, i + 1);
- s = s.substring(i + 1);
- break;
- }
+ for (int i = s.length(); i-- > 0;) {
+ if (s.charAt(i) == '/') {
+ d = s.substring(0, i + 1);
+ s = s.substring(i + 1);
+ break;
}
}
if (d != null) {
@@ -617,16 +591,12 @@
sb.append("//");
sb.append(authority.getStringValue());
}
- } else {
- if (!(this instanceof LogicalPathname)) {
- sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path.
- }
+ } else if (this instanceof LogicalPathname) {
sb.append(host.getStringValue());
- if (this instanceof LogicalPathname) {
- sb.append(':');
- } else {
- sb.append(File.separatorChar);
- }
+ sb.append(':');
+ } else {
+ // UNC paths now use unprintable representation
+ return null;
}
}
if (device == NIL) {
@@ -664,7 +634,7 @@
}
if (name instanceof AbstractString) {
String n = name.getStringValue();
- if (n.indexOf(File.separatorChar) >= 0) {
+ if (n.indexOf('/') >= 0) {
Debug.assertTrue(namestring == null);
return null;
}
@@ -735,12 +705,7 @@
// is, both NIL and :UNSPECIFIC cause the component not to appear in
// the namestring." 19.2.2.2.3.1
if (directory != NIL) {
- final char separatorChar;
- if (isJar() || isURL()) {
- separatorChar = '/';
- } else {
- separatorChar = File.separatorChar;
- }
+ final char separatorChar = '/';
LispObject temp = directory;
LispObject part = temp.car();
temp = temp.cdr();
@@ -788,18 +753,8 @@
p.invalidateNamestring();
String path = p.getNamestring();
StringBuilder result = new StringBuilder();
- if (Utilities.isPlatformWindows) {
- for (int i = 0; i < path.length(); i++) {
- char c = path.charAt(i);
- if (c == '\\') {
- result.append('/');
- } else {
- result.append(c);
- }
- }
- } else {
- result.append(path);
- }
+ result.append(path);
+
// Entries in jar files are always relative, but Pathname
// directories are :ABSOLUTE.
if (result.length() > 1
@@ -878,8 +833,8 @@
@Override
public String writeToString() {
final LispThread thread = LispThread.currentThread();
- boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL);
- boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL);
+ final boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL);
+ final boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL);
boolean useNamestring;
String s = null;
s = getNamestring();
@@ -901,7 +856,7 @@
}
}
}
- } else {
+ } else {
useNamestring = false;
}
StringBuilder sb = new StringBuilder();
@@ -923,41 +878,58 @@
sb.append('"');
}
} else {
- sb.append("#P(");
- if (host != NIL) {
- sb.append(":HOST ");
- sb.append(host.writeToString());
- sb.append(' ');
- }
- if (device != NIL) {
- sb.append(":DEVICE ");
- sb.append(device.writeToString());
- sb.append(' ');
- }
- if (directory != NIL) {
- sb.append(":DIRECTORY ");
- sb.append(directory.writeToString());
- sb.append(" ");
- }
- if (name != NIL) {
- sb.append(":NAME ");
- sb.append(name.writeToString());
- sb.append(' ');
- }
- if (type != NIL) {
- sb.append(":TYPE ");
- sb.append(type.writeToString());
- sb.append(' ');
- }
- if (version != NIL) {
- sb.append(":VERSION ");
- sb.append(version.writeToString());
- sb.append(' ');
- }
- if (sb.charAt(sb.length() - 1) == ' ') {
- sb.setLength(sb.length() - 1);
+ final SpecialBindingsMark mark = thread.markSpecialBindings();
+ thread.bindSpecial(Symbol.PRINT_ESCAPE, T);
+ try {
+ final boolean ANSI_COMPATIBLE = true;
+ final String SPACE = " ";
+ if (ANSI_COMPATIBLE) {
+ sb.append("#P(\"");
+ } else {
+ sb.append("#P(");
+
+ }
+ if (host != NIL) {
+ sb.append(":HOST ");
+ sb.append(host.writeToString());
+ sb.append(SPACE);
+ }
+ if (device != NIL) {
+ sb.append(":DEVICE ");
+ sb.append(device.writeToString());
+ sb.append(SPACE);
+ }
+ if (directory != NIL) {
+ sb.append(":DIRECTORY ");
+ sb.append(directory.writeToString());
+ sb.append(SPACE);
+ }
+ if (name != NIL) {
+ sb.append(":NAME ");
+ sb.append(name.writeToString());
+ sb.append(SPACE);
+ }
+ if (type != NIL) {
+ sb.append(":TYPE ");
+ sb.append(type.writeToString());
+ sb.append(SPACE);
+ }
+ if (version != NIL) {
+ sb.append(":VERSION ");
+ sb.append(version.writeToString());
+ sb.append(SPACE);
+ }
+ if (sb.charAt(sb.length() - 1) == ' ') { // XXX
+ sb.setLength(sb.length() - 1);
+ }
+ if (ANSI_COMPATIBLE) {
+ sb.append(')' + "\"");
+ } else {
+ sb.append(')');
+ }
+ } finally {
+ thread.resetSpecialBindings(mark);
}
- sb.append(')');
}
return sb.toString();
}
@@ -1233,7 +1205,7 @@
namestring = file.getCanonicalPath();
} catch (IOException e) {
Debug.trace("Failed to make a Pathname from "
- + "'" + file + "'");
+ + "." + file + "'");
return null;
}
return new Pathname(namestring);
@@ -1302,17 +1274,22 @@
}
final Pathname p;
final boolean logical;
+ LispObject logicalHost = NIL;
if (host != NIL) {
if (host instanceof AbstractString) {
- host = LogicalPathname.canonicalizeStringComponent((AbstractString) host);
+ logicalHost = LogicalPathname.canonicalizeStringComponent((AbstractString) host);
+ }
+ if (LOGICAL_PATHNAME_TRANSLATIONS.get(logicalHost) == null) {
+ // Not a defined logical pathname host -- A UNC path
+ //warning(new LispError(host.writeToString() + " is not defined as a logical pathname host."));
+ p = new Pathname();
+ logical = false;
+ p.host = host;
+ } else {
+ p = new LogicalPathname();
+ logical = true;
+ p.host = logicalHost;
}
- if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) {
- // Not a defined logical pathname host.
- error(new LispError(host.writeToString() + " is not defined as a logical pathname host."));
- }
- p = new LogicalPathname();
- logical = true;
- p.host = host;
p.device = Keyword.UNSPECIFIC;
} else {
p = new Pathname();
@@ -1375,6 +1352,7 @@
final int limit = s.length();
for (int i = 0; i < limit; i++) {
char c = s.charAt(i);
+ // XXX '\\' should be illegal in all Pathnames at this point?
if (c == '/' || c == '\\' && Utilities.isPlatformWindows) {
error(new LispError("Invalid character #\\" + c
+ " in pathname component \"" + s
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java Thu Jul 15 18:06:43 2010
@@ -235,9 +235,13 @@
// run-shell-command command &key directory (output *standard-output*)
// ### %run-shell-command command directory output => exit-code
- private static final Primitive _RUN_SHELL_COMMAND =
- new Primitive("%run-shell-command", PACKAGE_SYS, false)
- {
+ private static final Primitive _RUN_SHELL_COMMAND = new pf_run_shell_command();
+ private static class pf_run_shell_command extends Primitive {
+ pf_run_shell_command() {
+ super("%run-shell-command", PACKAGE_SYS, false,
+ "command directory output => exit-code");
+ }
+
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp Thu Jul 15 18:06:43 2010
@@ -209,11 +209,8 @@
(push-on-end (cadr olist) readers)
(push-on-end `(setf ,(cadr olist)) writers))
(t
- (push-on-end (car olist) non-std-options)
+ (push-on-end `(quote ,(car olist)) non-std-options)
(push-on-end (cadr olist) non-std-options))))
-; (error 'program-error
-; "invalid initialization argument ~S for slot named ~S"
-; (car olist) name))
`(list
:name ',name
,@(when initfunction
@@ -259,10 +256,7 @@
(cdr option))))))
((:documentation :report)
(list (car option) `',(cadr option)))
- (t (list (car option) `(quote ,(cdr option))))))
-; (error 'program-error
-; :format-control "invalid DEFCLASS option ~S"
-; :format-arguments (list (car option))))))
+ (t (list `(quote ,(car option)) `(quote ,(cdr option))))))
(defun make-initfunction (initform)
`(function (lambda () ,initform)))
@@ -337,8 +331,7 @@
(readers ())
(writers ())
(allocation :instance)
- (allocation-class nil)
- &allow-other-keys)
+ (allocation-class nil))
(setf (slot-definition-name slot) name)
(setf (slot-definition-initargs slot) initargs)
(setf (slot-definition-initform slot) initform)
@@ -2339,7 +2332,7 @@
(declare (ignore slot-names)) ;;TODO?
(declare (ignore name initargs initform initfunction readers writers allocation))
;;For built-in slots
- (apply #'init-slot-definition slot args)
+ (apply #'init-slot-definition slot :allow-other-keys t args)
;;For user-defined slots
(call-next-method))
Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp Thu Jul 15 18:06:43 2010
@@ -788,9 +788,15 @@
(let ((*precompile-env* (make-environment *precompile-env*))
(operator (car form))
(locals (cadr form))
- ;; precompile (thus macro-expand) the body before inspecting it
- ;; for the use of our locals and optimizing them away
- (body (mapcar #'precompile1 (cddr form))))
+ body)
+ ;; first augment the environment with the newly-defined local functions
+ ;; to shadow preexisting macro definitions with the same names
+ (dolist (local locals)
+ (environment-add-function-definition *precompile-env*
+ (car local) (cddr local)))
+ ;; then precompile (thus macro-expand) the body before inspecting it
+ ;; for the use of our locals and optimizing them away
+ (setq body (mapcar #'precompile1 (cddr form)))
(dolist (local locals)
(let* ((name (car local))
(used-p (find-use name body)))
More information about the armedbear-cvs
mailing list