[armedbear-cvs] r12105 - trunk/abcl/src/org/armedbear/lisp
Mark Evenson
mevenson at common-lisp.net
Wed Aug 19 14:51:59 UTC 2009
Author: mevenson
Date: Wed Aug 19 10:51:56 2009
New Revision: 12105
Log:
Split StackFrame abstraction into Java and Lisp stack frames.
>From the original patch/idea from Tobias Rittweiler this introduces
more information of primary interest to ABCL implemnters such as when
a form like (make-thread #'(lambda ())) is evaluated
All users of EXT:BACKTRACE-AS-LIST should now use SYS:BACKTRACE, the
results of which is a list of the new builtin classes JAVA_STACK_FRAME
or LISP_STACK_FRAME. The methods SYS:FRAME-TO-STRING and
SYS:FRAME-TO-LIST are defined to break these new objects into
inspectable parts. As a convenience, there is a SYS:BACKTRACE-AS-LIST
which calls SYS:FRAME-TO-LIST to each element of the computed
backtrace.
Refactorings have occurred on the Java side: the misnamed
LispThread.backtrace() is now LispThread.printBacktrace().
LispThread.backtraceAsList() is now LispThread.backtrace() as it is
a shorter name, and more to the point.
Java stack frames only appear after a call through Lisp.error(), which
has only the top level as a restart as an option.
Added:
trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java (contents, props changed)
trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java (contents, props changed)
trunk/abcl/src/org/armedbear/lisp/StackFrame.java (contents, props changed)
Modified:
trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
trunk/abcl/src/org/armedbear/lisp/Interpreter.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/LispThread.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/boot.lisp
trunk/abcl/src/org/armedbear/lisp/debug.lisp
trunk/abcl/src/org/armedbear/lisp/signal.lisp
trunk/abcl/src/org/armedbear/lisp/top-level.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Wed Aug 19 10:51:56 2009
@@ -142,6 +142,10 @@
public static final BuiltInClass THREAD = addClass(Symbol.THREAD);
public static final BuiltInClass TWO_WAY_STREAM = addClass(Symbol.TWO_WAY_STREAM);
public static final BuiltInClass VECTOR = addClass(Symbol.VECTOR);
+ public static final BuiltInClass STACK_FRAME = addClass(Symbol.STACK_FRAME);
+ public static final BuiltInClass LISP_STACK_FRAME = addClass(Symbol.LISP_STACK_FRAME);
+ public static final BuiltInClass JAVA_STACK_FRAME = addClass(Symbol.JAVA_STACK_FRAME);
+
public static final StructureClass STRUCTURE_OBJECT =
new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T));
@@ -275,6 +279,12 @@
TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, STREAM, CLASS_T);
VECTOR.setDirectSuperclasses(list(ARRAY, SEQUENCE));
VECTOR.setCPL(VECTOR, ARRAY, SEQUENCE, CLASS_T);
+ STACK_FRAME.setDirectSuperclasses(CLASS_T);
+ STACK_FRAME.setCPL(STACK_FRAME, CLASS_T);
+ LISP_STACK_FRAME.setDirectSuperclasses(STACK_FRAME);
+ LISP_STACK_FRAME.setCPL(LISP_STACK_FRAME, STACK_FRAME, CLASS_T);
+ JAVA_STACK_FRAME.setDirectSuperclasses(STACK_FRAME);
+ JAVA_STACK_FRAME.setCPL(JAVA_STACK_FRAME, STACK_FRAME, CLASS_T);
}
static
Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Wed Aug 19 10:51:56 2009
@@ -389,7 +389,7 @@
catch (Throwable t) {
getStandardInput().clearInput();
out.printStackTrace(t);
- thread.backtrace();
+ thread.printBacktrace();
}
}
}
@@ -408,7 +408,7 @@
out._writeLine("Error: unhandled condition: " +
condition.writeToString());
if (thread != null)
- thread.backtrace();
+ thread.printBacktrace();
}
catch (Throwable t) {
Added: trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java Wed Aug 19 10:51:56 2009
@@ -0,0 +1,133 @@
+/*
+ * JavaStackFrame.java
+ *
+ * Copyright (C) 2009 Mark Evenson
+ * $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.
+ *
+ * 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.
+ */
+
+package org.armedbear.lisp;
+
+public class JavaStackFrame
+ extends StackFrame
+{
+ public final StackTraceElement javaFrame;
+
+ public JavaStackFrame(StackTraceElement javaFrame)
+ {
+ this.javaFrame = javaFrame;
+ }
+
+ @Override
+ public LispObject typeOf() {
+ return Symbol.JAVA_STACK_FRAME;
+ }
+
+ @Override
+ public LispObject classOf() { return BuiltInClass.JAVA_STACK_FRAME; }
+
+ @Override
+ public String writeToString() {
+ String result = null;
+ final String JAVA_STACK_FRAME = "JAVA-STACK-FRAME";
+ try {
+ result = unreadableString(JAVA_STACK_FRAME + " "
+ + toLispString().toString());
+ } catch (ConditionThrowable t) {
+ Debug.trace("Implementation error: ");
+ Debug.trace(t);
+ result = unreadableString(JAVA_STACK_FRAME);
+ }
+ return result;
+ }
+
+ @Override
+ public LispObject typep(LispObject typeSpecifier)
+ throws ConditionThrowable
+ {
+ if (typeSpecifier == Symbol.JAVA_STACK_FRAME)
+ return T;
+ if (typeSpecifier == BuiltInClass.JAVA_STACK_FRAME)
+ return T;
+ return super.typep(typeSpecifier);
+ }
+
+ static final Symbol CLASS = Packages.internKeyword("CLASS");
+ static final Symbol METHOD = Packages.internKeyword("METHOD");
+ static final Symbol FILE = Packages.internKeyword("FILE");
+ static final Symbol LINE = Packages.internKeyword("LINE");
+ static final Symbol NATIVE_METHOD = Packages.internKeyword("NATIVE-METHOD");
+
+ public LispObject toLispList() throws ConditionThrowable
+ {
+ LispObject result = Lisp.NIL;
+
+ if ( javaFrame == null)
+ return result;
+
+ result = result.push(CLASS);
+ result = result.push(new SimpleString(javaFrame.getClassName()));
+ result = result.push(METHOD);
+ result = result.push(new SimpleString(javaFrame.getMethodName()));
+ result = result.push(FILE);
+ result = result.push(new SimpleString(javaFrame.getFileName()));
+ result = result.push(LINE);
+ result = result.push(Fixnum.getInstance(javaFrame.getLineNumber()));
+ if (javaFrame.isNativeMethod()) {
+ result = result.push(NATIVE_METHOD);
+ result = result.push(Symbol.T);
+ }
+
+ return result.nreverse();
+ }
+
+ @Override
+ public SimpleString toLispString()
+ throws ConditionThrowable
+ {
+ return new SimpleString(javaFrame.toString());
+ }
+
+ @Override
+ public LispObject getParts()
+ throws ConditionThrowable
+ {
+ LispObject result = NIL;
+ result = result.push(new Cons("CLASS",
+ new SimpleString(javaFrame.getClassName())));
+ result = result.push(new Cons("METHOD",
+ new SimpleString(javaFrame.getMethodName())));
+ result = result.push(new Cons("FILE",
+ new SimpleString(javaFrame.getFileName())));
+ result = result.push(new Cons("LINE",
+ Fixnum.getInstance(javaFrame.getLineNumber())));
+ result = result.push(new Cons("NATIVE-METHOD",
+ LispObject.getInstance(javaFrame.isNativeMethod())));
+ return result.nreverse();
+ }
+}
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Aug 19 10:51:56 2009
@@ -271,7 +271,7 @@
catch (StackOverflowError e)
{
thread.setSpecialVariable(_SAVED_BACKTRACE_,
- thread.backtraceAsList(0));
+ thread.backtrace(0));
return error(new StorageCondition("Stack overflow."));
}
catch (Go go)
@@ -287,7 +287,7 @@
{
Debug.trace(t);
thread.setSpecialVariable(_SAVED_BACKTRACE_,
- thread.backtraceAsList(0));
+ thread.backtrace(0));
return error(new LispError("Caught " + t + "."));
}
Debug.assertTrue(result != null);
@@ -320,15 +320,39 @@
}
};
+ private static final void pushJavaStackFrames() throws ConditionThrowable
+ {
+ final LispThread thread = LispThread.currentThread();
+ final StackTraceElement[] frames = thread.getJavaStackTrace();
+
+ // Search for last Primitive in the StackTrace; that was the
+ // last entry point from Lisp.
+ int last = frames.length - 1;
+ for (int i = 0; i<= last; i++) {
+ if (frames[i].getClassName().startsWith("org.armedbear.lisp.Primitive"))
+ last = i;
+ }
+ // Do not include the first three frames:
+ // Thread.getStackTrace, LispThread.getJavaStackTrace,
+ // Lisp.pushJavaStackFrames.
+ while (last > 2) {
+ thread.pushStackFrame(new JavaStackFrame(frames[last]));
+ last--;
+ }
+ }
+
+
public static final LispObject error(LispObject condition)
throws ConditionThrowable
{
+ pushJavaStackFrames();
return Symbol.ERROR.execute(condition);
}
public static final LispObject error(LispObject condition, LispObject message)
throws ConditionThrowable
{
+ pushJavaStackFrames();
return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message);
}
@@ -852,6 +876,14 @@
type_error(obj, Symbol.SINGLE_FLOAT);
}
+ public static final StackFrame checkStackFrame(LispObject obj)
+ throws ConditionThrowable
+ {
+ if (obj instanceof StackFrame)
+ return (StackFrame) obj;
+ return (StackFrame)// Not reached.
+ type_error(obj, Symbol.STACK_FRAME);
+ }
static
{
Added: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Wed Aug 19 10:51:56 2009
@@ -0,0 +1,193 @@
+/*
+ * LispStackFrame.java
+ *
+ * Copyright (C) 2009 Mark Evenson
+ * $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.
+ *
+ * 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.
+ */
+
+package org.armedbear.lisp;
+
+public class LispStackFrame
+ extends StackFrame
+{
+ public final LispObject operator;
+ private final LispObject first;
+ private final LispObject second;
+ private final LispObject third;
+ private final LispObject[] args;
+
+ public LispStackFrame(LispObject operator)
+ {
+ this.operator = operator;
+ first = null;
+ second = null;
+ third = null;
+ args = null;
+ }
+
+ public LispStackFrame(LispObject operator, LispObject arg)
+ {
+ this.operator = operator;
+ first = arg;
+ second = null;
+ third = null;
+ args = null;
+ }
+
+ public LispStackFrame(LispObject operator, LispObject first,
+ LispObject second)
+ {
+ this.operator = operator;
+ this.first = first;
+ this.second = second;
+ third = null;
+ args = null;
+ }
+
+ public LispStackFrame(LispObject operator, LispObject first,
+ LispObject second, LispObject third)
+
+ {
+ this.operator = operator;
+ this.first = first;
+ this.second = second;
+ this.third = third;
+ args = null;
+ }
+
+ public LispStackFrame(LispObject operator, LispObject... args)
+ {
+ this.operator = operator;
+ first = null;
+ second = null;
+ third = null;
+ final int length = args.length;
+ this.args = new LispObject[length];
+ System.arraycopy(args, 0, this.args, 0, length);
+ }
+
+ @Override
+ public LispObject typeOf() {
+ return Symbol.LISP_STACK_FRAME;
+ }
+
+ @Override
+ public LispObject classOf() {
+ return BuiltInClass.LISP_STACK_FRAME;
+ }
+
+ @Override
+ public String writeToString()
+ {
+ String result = "";
+ final String LISP_STACK_FRAME = "LISP-STACK-FRAME";
+ try {
+ result = unreadableString(LISP_STACK_FRAME + " "
+ + toLispString().getStringValue());
+ } catch (ConditionThrowable t) {
+ Debug.trace("Implementation error: ");
+ Debug.trace(t);
+ result = unreadableString(LISP_STACK_FRAME);
+ }
+ return result;
+ }
+
+ @Override
+ public LispObject typep(LispObject typeSpecifier)
+ throws ConditionThrowable
+ {
+ if (typeSpecifier == Symbol.LISP_STACK_FRAME)
+ return T;
+ if (typeSpecifier == BuiltInClass.LISP_STACK_FRAME)
+ return T;
+ return super.typep(typeSpecifier);
+ }
+
+ public LispObject toLispList()
+ throws ConditionThrowable
+ {
+ LispObject result = argsToLispList();
+ if (operator instanceof Operator) {
+ LispObject lambdaName = ((Operator)operator).getLambdaName();
+ if (lambdaName != null && lambdaName != Lisp.NIL)
+ return result.push(lambdaName);
+ }
+ return result.push(operator);
+ }
+
+ private LispObject argsToLispList()
+ throws ConditionThrowable
+ {
+ LispObject result = Lisp.NIL;
+ if (args != null) {
+ for (int i = 0; i < args.length; i++)
+ result = result.push(args[i]);
+ } else {
+ do {
+ if (first != null)
+ result = result.push(first);
+ else
+ break;
+ if (second != null)
+ result = result.push(second);
+ else
+ break;
+ if (third != null)
+ result = result.push(third);
+ else
+ break;
+ } while (false);
+ }
+ return result.nreverse();
+ }
+
+ public SimpleString toLispString()
+ throws ConditionThrowable
+ {
+ return new SimpleString(toLispList().writeToString());
+ }
+
+ public LispObject getOperator() {
+ return operator;
+ }
+
+ @Override
+ public LispObject getParts()
+ throws ConditionThrowable
+ {
+ LispObject result = NIL;
+ result = result.push(new Cons("OPERATOR", getOperator()));
+ LispObject args = argsToLispList();
+ if (args != NIL) {
+ result = result.push(new Cons("ARGS", args));
+ }
+
+ return result.nreverse();
+ }
+}
Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Wed Aug 19 10:51:56 2009
@@ -117,6 +117,10 @@
javaThread.start();
}
+ public StackTraceElement[] getJavaStackTrace() {
+ return javaThread.getStackTrace();
+ }
+
@Override
public LispObject typeOf()
{
@@ -447,98 +451,6 @@
tag.writeToString() + "."));
}
- private static class StackFrame
- {
- public final LispObject operator;
- private final LispObject first;
- private final LispObject second;
- private final LispObject third;
- private final LispObject[] args;
- final StackFrame next;
-
- public StackFrame(LispObject operator, StackFrame next)
- {
- this.operator = operator;
- first = null;
- second = null;
- third = null;
- args = null;
- this.next = next;
- }
-
- public StackFrame(LispObject operator, LispObject arg, StackFrame next)
- {
- this.operator = operator;
- first = arg;
- second = null;
- third = null;
- args = null;
- this.next = next;
- }
-
- public StackFrame(LispObject operator, LispObject first,
- LispObject second, StackFrame next)
- {
- this.operator = operator;
- this.first = first;
- this.second = second;
- third = null;
- args = null;
- this.next = next;
- }
-
- public StackFrame(LispObject operator, LispObject first,
- LispObject second, LispObject third, StackFrame next)
- {
- this.operator = operator;
- this.first = first;
- this.second = second;
- this.third = third;
- args = null;
- this.next = next;
- }
-
- public StackFrame(LispObject operator, LispObject[] args, StackFrame next)
- {
- this.operator = operator;
- first = null;
- second = null;
- third = null;
- this.args = args;
- this.next = next;
- }
-
- public LispObject toList() throws ConditionThrowable
- {
- LispObject list = NIL;
- if (args != null) {
- for (int i = 0; i < args.length; i++)
- list = list.push(args[i]);
- } else {
- do {
- if (first != null)
- list = list.push(first);
- else
- break;
- if (second != null)
- list = list.push(second);
- else
- break;
- if (third != null)
- list = list.push(third);
- else
- break;
- } while (false);
- }
- list = list.nreverse();
- if (operator instanceof Operator) {
- LispObject lambdaName = ((Operator)operator).getLambdaName();
- if (lambdaName != null && lambdaName != NIL)
- return list.push(lambdaName);
- }
- return list.push(operator);
- }
- }
private StackFrame stack = null;
@@ -553,42 +465,18 @@
{
}
- public final void pushStackFrame(LispObject operator)
- throws ConditionThrowable
- {
- stack = new StackFrame(operator, stack);
- }
-
- public final void pushStackFrame(LispObject operator, LispObject arg)
- throws ConditionThrowable
- {
- stack = new StackFrame(operator, arg, stack);
- }
-
- public final void pushStackFrame(LispObject operator, LispObject first,
- LispObject second)
- throws ConditionThrowable
+ public final void pushStackFrame(StackFrame frame)
+ throws ConditionThrowable
{
- stack = new StackFrame(operator, first, second, stack);
+ frame.setNext(stack);
+ stack = frame;
}
- public final void pushStackFrame(LispObject operator, LispObject first,
- LispObject second, LispObject third)
- throws ConditionThrowable
- {
- stack = new StackFrame(operator, first, second, third, stack);
- }
-
- public final void pushStackFrame(LispObject operator, LispObject... args)
- throws ConditionThrowable
- {
- stack = new StackFrame(operator, args, stack);
- }
public final void popStackFrame()
{
if (stack != null)
- stack = stack.next;
+ stack = stack.getNext();
}
public void resetStack()
@@ -602,7 +490,7 @@
if (use_fast_calls)
return function.execute();
- pushStackFrame(function);
+ pushStackFrame(new LispStackFrame(function));
try {
return function.execute();
}
@@ -618,7 +506,7 @@
if (use_fast_calls)
return function.execute(arg);
- pushStackFrame(function, arg);
+ pushStackFrame(new LispStackFrame(function, arg));
try {
return function.execute(arg);
}
@@ -635,7 +523,7 @@
if (use_fast_calls)
return function.execute(first, second);
- pushStackFrame(function, first, second);
+ pushStackFrame(new LispStackFrame(function, first, second));
try {
return function.execute(first, second);
}
@@ -652,7 +540,7 @@
if (use_fast_calls)
return function.execute(first, second, third);
- pushStackFrame(function, first, second, third);
+ pushStackFrame(new LispStackFrame(function, first, second, third));
try {
return function.execute(first, second, third);
}
@@ -670,7 +558,7 @@
if (use_fast_calls)
return function.execute(first, second, third, fourth);
- pushStackFrame(function, first, second, third, fourth);
+ pushStackFrame(new LispStackFrame(function, first, second, third, fourth));
try {
return function.execute(first, second, third, fourth);
}
@@ -688,7 +576,7 @@
if (use_fast_calls)
return function.execute(first, second, third, fourth, fifth);
- pushStackFrame(function, first, second, third, fourth, fifth);
+ pushStackFrame(new LispStackFrame(function, first, second, third, fourth, fifth));
try {
return function.execute(first, second, third, fourth, fifth);
}
@@ -707,7 +595,8 @@
if (use_fast_calls)
return function.execute(first, second, third, fourth, fifth, sixth);
- pushStackFrame(function, first, second, third, fourth, fifth, sixth);
+ pushStackFrame(new LispStackFrame(function, first, second,
+ third, fourth, fifth, sixth));
try {
return function.execute(first, second, third, fourth, fifth, sixth);
}
@@ -727,8 +616,8 @@
return function.execute(first, second, third, fourth, fifth, sixth,
seventh);
- pushStackFrame(function, first, second, third, fourth, fifth, sixth,
- seventh);
+ pushStackFrame(new LispStackFrame(function, first, second, third,
+ fourth, fifth, sixth, seventh));
try {
return function.execute(first, second, third, fourth, fifth, sixth,
seventh);
@@ -749,8 +638,8 @@
return function.execute(first, second, third, fourth, fifth, sixth,
seventh, eighth);
- pushStackFrame(function, first, second, third, fourth, fifth, sixth,
- seventh, eighth);
+ pushStackFrame(new LispStackFrame(function, first, second, third,
+ fourth, fifth, sixth, seventh, eighth));
try {
return function.execute(first, second, third, fourth, fifth, sixth,
seventh, eighth);
@@ -766,7 +655,7 @@
if (use_fast_calls)
return function.execute(args);
- pushStackFrame(function, args);
+ pushStackFrame(new LispStackFrame(function, args));
try {
return function.execute(args);
}
@@ -775,12 +664,12 @@
}
}
- public void backtrace()
+ public void printBacktrace()
{
- backtrace(0);
+ printBacktrace(0);
}
- public void backtrace(int limit)
+ public void printBacktrace(int limit)
{
if (stack != null) {
try {
@@ -796,7 +685,7 @@
out._writeString(String.valueOf(count));
out._writeString(": ");
- pprint(s.toList(), out.getCharPos(), out);
+ pprint(s.toLispList(), out.getCharPos(), out);
out.terpri();
out._finishOutput();
if (limit > 0 && ++count == limit)
@@ -810,7 +699,7 @@
}
}
- public LispObject backtraceAsList(int limit) throws ConditionThrowable
+ public LispObject backtrace(int limit) throws ConditionThrowable
{
LispObject result = NIL;
if (stack != null) {
@@ -818,10 +707,10 @@
try {
StackFrame s = stack;
while (s != null) {
- result = result.push(s.toList());
+ result = result.push(s);
if (limit > 0 && ++count == limit)
break;
- s = s.next;
+ s = s.getNext();
}
}
catch (Throwable t) {
@@ -838,19 +727,23 @@
for (int i = 0; i < 8; i++) {
if (s == null)
break;
- LispObject operator = s.operator;
- if (operator != null) {
- operator.incrementHotCount();
- operator.incrementCallCount();
- }
- s = s.next;
+ if (s instanceof LispStackFrame) {
+ LispObject operator = ((LispStackFrame)s).getOperator();
+ if (operator != null) {
+ operator.incrementHotCount();
+ operator.incrementCallCount();
+ }
+ s = s.getNext();
+ }
}
while (s != null) {
- LispObject operator = s.operator;
- if (operator != null)
- operator.incrementCallCount();
- s = s.next;
+ if (s instanceof LispStackFrame) {
+ LispObject operator = ((LispStackFrame)s).getOperator();
+ if (operator != null)
+ operator.incrementCallCount();
+ }
+ s = s.getNext();
}
}
@@ -1110,10 +1003,10 @@
}
};
- // ### backtrace-as-list
- private static final Primitive BACKTRACE_AS_LIST =
- new Primitive("backtrace-as-list", PACKAGE_EXT, true, "",
- "Returns a backtrace of the invoking thread as a list.")
+ // ### backtrace
+ private static final Primitive BACKTRACE =
+ new Primitive("backtrace", PACKAGE_SYS, true, "",
+ "Returns a backtrace of the invoking thread.")
{
@Override
public LispObject execute(LispObject[] args)
@@ -1122,9 +1015,39 @@
if (args.length > 1)
return error(new WrongNumberOfArgumentsException(this));
int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0;
- return currentThread().backtraceAsList(limit);
+ return currentThread().backtrace(limit);
}
};
+ // ### frame-to-string
+ private static final Primitive FRAME_TO_STRING =
+ new Primitive("frame-to-string", PACKAGE_SYS, true, "frame")
+ {
+ @Override
+ public LispObject execute(LispObject[] args)
+ throws ConditionThrowable
+ {
+ if (args.length != 1)
+ return error(new WrongNumberOfArgumentsException(this));
+
+ return checkStackFrame(args[0]).toLispString();
+ }
+ };
+
+ // ### frame-to-list
+ private static final Primitive FRAME_TO_LIST =
+ new Primitive("frame-to-list", PACKAGE_SYS, true, "frame")
+ {
+ @Override
+ public LispObject execute(LispObject[] args)
+ throws ConditionThrowable
+ {
+ if (args.length != 1)
+ return error(new WrongNumberOfArgumentsException(this));
+
+ return checkStackFrame(args[0]).toLispList();
+ }
+ };
+
static {
//FIXME: this block has been added for pre-0.16 compatibility
Added: trunk/abcl/src/org/armedbear/lisp/StackFrame.java
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/StackFrame.java Wed Aug 19 10:51:56 2009
@@ -0,0 +1,61 @@
+/*
+ * StackFrame.java
+ *
+ * Copyright (C) 2009 Mark Evenson
+ * $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.
+ *
+ * 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.
+ */
+
+package org.armedbear.lisp;
+
+public abstract class StackFrame
+ extends LispObject
+{
+ @Override
+ public LispObject typep(LispObject typeSpecifier)
+ throws ConditionThrowable
+ {
+ if (typeSpecifier == Symbol.STACK_FRAME)
+ return T;
+ if (typeSpecifier == BuiltInClass.STACK_FRAME)
+ return T;
+ return super.typep(typeSpecifier);
+ }
+
+ StackFrame next;
+
+ void setNext(StackFrame nextFrame) {
+ this.next = nextFrame;
+ }
+ StackFrame getNext() {
+ return this.next;
+ }
+
+ public abstract LispObject toLispList() throws ConditionThrowable;
+ public abstract SimpleString toLispString() throws ConditionThrowable;
+}
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Aug 19 10:51:56 2009
@@ -3039,6 +3039,12 @@
PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM");
public static final Symbol STRING_OUTPUT_STREAM =
PACKAGE_SYS.addInternalSymbol("STRING-OUTPUT-STREAM");
+ public static final Symbol STACK_FRAME =
+ PACKAGE_SYS.addInternalSymbol("STACK-FRAME");
+ public static final Symbol LISP_STACK_FRAME =
+ PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME");
+ public static final Symbol JAVA_STACK_FRAME =
+ PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME");
// CDR6
public static final Symbol _INSPECTOR_HOOK_ =
Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Wed Aug 19 10:51:56 2009
@@ -334,7 +334,6 @@
(load-system-file "defsetf")
(load-system-file "package")
-
(defun preload-package (pkg)
(%format t "Preloading ~S~%" (find-package pkg))
(dolist (sym (package-symbols pkg))
Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/debug.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/debug.lisp Wed Aug 19 10:51:56 2009
@@ -100,7 +100,7 @@
(simple-format *debug-io* " ~A~%" condition)))))
(defun invoke-debugger (condition)
- (let ((*saved-backtrace* (backtrace-as-list)))
+ (let ((*saved-backtrace* (sys:backtrace)))
(when *debugger-hook*
(let ((hook-function *debugger-hook*)
(*debugger-hook* nil))
@@ -129,3 +129,7 @@
(list :format-control format-control
:format-arguments format-arguments))))
nil))
+
+(defun backtrace-as-list (&optional (n 0))
+ "Return BACKTRACE with each element converted to a list."
+ (mapcar #'sys::frame-to-list (sys:backtrace n)))
Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/signal.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/signal.lisp Wed Aug 19 10:51:56 2009
@@ -49,7 +49,7 @@
(let* ((old-bos *break-on-signals*)
(*break-on-signals* nil))
(when (typep condition old-bos)
- (let ((*saved-backtrace* (backtrace-as-list)))
+ (let ((*saved-backtrace* (sys:backtrace)))
(break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)."
condition))))
(loop
Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/top-level.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Wed Aug 19 10:51:56 2009
@@ -102,6 +102,23 @@
(%format *debug-io* "~A~%" s))
(show-restarts (compute-restarts) *debug-io*)))
+(defun print-frame (frame stream &key prefix)
+ (when prefix
+ (write-string prefix stream))
+ (etypecase frame
+ (sys::lisp-stack-frame
+ (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+ (setq frame (sys:frame-to-list frame))
+ (ignore-errors
+ (prin1 (car frame) stream)
+ (let ((args (cdr frame)))
+ (if (listp args)
+ (format stream "~{ ~_~S~}" args)
+ (format stream " ~S" args))))))
+ (sys::java-stack-frame
+ (write-string (sys:frame-to-string frame) stream))))
+
+
(defun backtrace-command (args)
(let ((count (or (and args (ignore-errors (parse-integer args)))
8))
@@ -113,14 +130,7 @@
(*print-array* nil))
(dolist (frame *saved-backtrace*)
(fresh-line *debug-io*)
- (let ((prefix (format nil "~3D: (" n)))
- (pprint-logical-block (*debug-io* nil :prefix prefix :suffix ")")
- (ignore-errors
- (prin1 (car frame) *debug-io*)
- (let ((args (cdr frame)))
- (if (listp args)
- (format *debug-io* "~{ ~_~S~}" args)
- (format *debug-io* " ~S" args))))))
+ (print-frame frame *debug-io* :prefix (format nil "~3D: " n))
(incf n)
(when (>= n count)
(return))))))
@@ -136,12 +146,7 @@
(*print-readably* nil)
(*print-structure* nil))
(fresh-line *debug-io*)
- (pprint-logical-block (*debug-io* nil :prefix "(" :suffix ")")
- (prin1 (car frame) *debug-io*)
- (let ((args (cdr frame)))
- (if (listp args)
- (format *debug-io* "~{ ~_~S~}" args)
- (format *debug-io* " ~S" args))))))
+ (print-frame frame *debug-io*)))
(setf *** **
** *
* frame)))
More information about the armedbear-cvs
mailing list