diff -r f31bcf073d6f src/org/armedbear/lisp/BuiltInClass.java --- a/src/org/armedbear/lisp/BuiltInClass.java Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/BuiltInClass.java Mon Aug 03 15:36:36 2009 +0200 @@ -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 diff -r f31bcf073d6f src/org/armedbear/lisp/Interpreter.java --- a/src/org/armedbear/lisp/Interpreter.java Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/Interpreter.java Mon Aug 03 15:36:36 2009 +0200 @@ -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) { diff -r f31bcf073d6f src/org/armedbear/lisp/JavaStackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/JavaStackFrame.java Mon Aug 03 15:36:36 2009 +0200 @@ -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(); + } +} diff -r f31bcf073d6f src/org/armedbear/lisp/Lisp.java --- a/src/org/armedbear/lisp/Lisp.java Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/Lisp.java Mon Aug 03 15:36:36 2009 +0200 @@ -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 { diff -r f31bcf073d6f src/org/armedbear/lisp/LispStackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/LispStackFrame.java Mon Aug 03 15:36:36 2009 +0200 @@ -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(); + } +} diff -r f31bcf073d6f src/org/armedbear/lisp/LispThread.java --- a/src/org/armedbear/lisp/LispThread.java Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/LispThread.java Mon Aug 03 15:36:36 2009 +0200 @@ -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 + public final void pushStackFrame(StackFrame frame) + throws ConditionThrowable { - stack = new StackFrame(operator, stack); + frame.setNext(stack); + stack = frame; } - 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 - { - stack = new StackFrame(operator, first, second, stack); - } - - 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 diff -r f31bcf073d6f src/org/armedbear/lisp/StackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/StackFrame.java Mon Aug 03 15:36:36 2009 +0200 @@ -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; +} diff -r f31bcf073d6f src/org/armedbear/lisp/Symbol.java --- a/src/org/armedbear/lisp/Symbol.java Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/Symbol.java Mon Aug 03 15:36:36 2009 +0200 @@ -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_ = diff -r f31bcf073d6f src/org/armedbear/lisp/boot.lisp --- a/src/org/armedbear/lisp/boot.lisp Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/boot.lisp Mon Aug 03 15:36:36 2009 +0200 @@ -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)) diff -r f31bcf073d6f src/org/armedbear/lisp/debug.lisp --- a/src/org/armedbear/lisp/debug.lisp Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/debug.lisp Mon Aug 03 15:36:36 2009 +0200 @@ -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))) diff -r f31bcf073d6f src/org/armedbear/lisp/signal.lisp --- a/src/org/armedbear/lisp/signal.lisp Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/signal.lisp Mon Aug 03 15:36:36 2009 +0200 @@ -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 diff -r f31bcf073d6f src/org/armedbear/lisp/top-level.lisp --- a/src/org/armedbear/lisp/top-level.lisp Sat Aug 01 09:58:15 2009 +0200 +++ b/src/org/armedbear/lisp/top-level.lisp Mon Aug 03 15:36:36 2009 +0200 @@ -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)))