diff -r ae68bf89ae8c src/org/armedbear/lisp/BuiltInClass.java --- a/src/org/armedbear/lisp/BuiltInClass.java Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/BuiltInClass.java Thu Jul 30 11:48:43 2009 +0200 @@ -143,6 +143,10 @@ 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)); static @@ -275,6 +279,13 @@ 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 ae68bf89ae8c src/org/armedbear/lisp/Debug.java --- a/src/org/armedbear/lisp/Debug.java Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/Debug.java Thu Jul 30 11:48:43 2009 +0200 @@ -51,6 +51,11 @@ trace(new Exception("BUG!")); } + public static final void warn(String s) + { + trace("WARN: " + s); + } + public static final void trace(String s) { System.err.println(s); diff -r ae68bf89ae8c src/org/armedbear/lisp/JavaStackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/JavaStackFrame.java Thu Jul 30 11:48:43 2009 +0200 @@ -0,0 +1,83 @@ +/* + * 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() { return unreadableString("JAVA-STACK-FRAME"); } + + @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); + } + + Symbol CLASSNAME = Lisp.internKeyword("CLASSNAME"); + + public LispObject frameToList() throws ConditionThrowable + { + LispObject result = Lisp.NIL; + + if ( javaFrame == null) + return result; + + result = result.push(frameToString()); + + return result.nreverse(); + } + + public SimpleString frameToString() throws ConditionThrowable { + return new SimpleString(javaFrame.toString()); + } + +} diff -r ae68bf89ae8c src/org/armedbear/lisp/Lisp.java --- a/src/org/armedbear/lisp/Lisp.java Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/Lisp.java Thu Jul 30 11:48:43 2009 +0200 @@ -320,15 +320,78 @@ } }; + /** + * Push "meaningful" Java stack frames to the invoking LispThread's stack. + * + * N.B. After this method is invoked, the invoking ListThread will + * not be restartable execept on the top level as its stack will + * contain Java stack frames. + */ + private static final void pushJavaStackFrames() + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final StackTraceElement[] frames = thread.getJavaStackTrace(); + + // Possibly trim the java stack between the top instance of + // "org.armedbear.lisp.Primitive" which is the last point in the + // Java stack where Lisp was executed, and bottom instance of + // "org.armedbear.lisp.Lisp.error" which is the only method that + // directly invokes this function. + int top = -1; + int bottom = -1; + final String topSymbol = "org.armedbear.lisp.Primitive."; + final String bottomSymbol = "org.armedbear.lisp.Lisp.error"; + + int i = 0; + for (StackTraceElement frame : frames) { + final String f = frame.toString(); + if (f.startsWith(topSymbol)) { + top = i; + } + if (f.startsWith(bottomSymbol)) { + bottom = i; + } + if (bottom != -1 && top != -1) { + break; + } + i++; + } + + // Sometimes the search for the the enclosing symbols fail, for + // instance when intializing the interpreter, so we explicitly + // guard against those cases. + if (top == -1) { + Debug.warn("Failed to find instance of '" + + topSymbol+ "' in Java stack trace."); + top = frames.length - 1; + } + if (bottom == -1) { + Debug.warn("Failed to find instance of '" + + bottomSymbol+ "' in Java stack trace."); + bottom = 0; + } + + i = top; + while (i >= bottom) { + thread.pushStackFrame(new JavaStackFrame(frames[i])); + i--; + } + return; + } + + 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 +915,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 ae68bf89ae8c src/org/armedbear/lisp/LispStackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/LispStackFrame.java Thu Jul 30 11:48:43 2009 +0200 @@ -0,0 +1,150 @@ +/* + * 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() { return unreadableString("LISP-STACK-FRAME"); } + + @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 frameToList() + throws ConditionThrowable + { + LispObject list = Lisp.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 != Lisp.NIL) + return list.push(lambdaName); + } + return list.push(operator); + } + + public SimpleString frameToString() throws ConditionThrowable { + return new SimpleString(frameToList().writeToString()); + } +} diff -r ae68bf89ae8c src/org/armedbear/lisp/LispThread.java --- a/src/org/armedbear/lisp/LispThread.java Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/LispThread.java Thu Jul 30 11:48:43 2009 +0200 @@ -117,6 +117,10 @@ javaThread.start(); } + public StackTraceElement[] getJavaStackTrace() { + return javaThread.getStackTrace(); + } + @Override public LispObject typeOf() { @@ -447,99 +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; @Deprecated @@ -560,40 +471,11 @@ Profiler.sample(this); } - public final void pushStackFrame(LispObject operator) + public final void pushStackFrame(StackFrame frame) throws ConditionThrowable { - stack = new StackFrame(operator, stack); - doProfiling(); - } - - public final void pushStackFrame(LispObject operator, LispObject arg) - throws ConditionThrowable - { - stack = new StackFrame(operator, arg, stack); - doProfiling(); - } - - public final void pushStackFrame(LispObject operator, LispObject first, - LispObject second) - throws ConditionThrowable - { - stack = new StackFrame(operator, first, second, stack); - doProfiling(); - } - - public final void pushStackFrame(LispObject operator, LispObject first, - LispObject second, LispObject third) - throws ConditionThrowable - { - stack = new StackFrame(operator, first, second, third, stack); - doProfiling(); - } - - public final void pushStackFrame(LispObject operator, LispObject... args) - throws ConditionThrowable - { - stack = new StackFrame(operator, args, stack); + frame.setNext(stack); + stack = frame; doProfiling(); } @@ -614,7 +496,7 @@ if (use_fast_calls) return function.execute(); - pushStackFrame(function); + pushStackFrame(new LispStackFrame(function)); try { return function.execute(); } @@ -631,7 +513,7 @@ if (use_fast_calls) return function.execute(arg); - pushStackFrame(function, arg); + pushStackFrame(new LispStackFrame(function, arg)); try { return function.execute(arg); } @@ -649,7 +531,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); } @@ -667,7 +549,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); } @@ -686,7 +568,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); } @@ -705,7 +587,8 @@ 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); } @@ -725,7 +608,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); } @@ -746,8 +630,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); @@ -769,8 +653,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); @@ -787,7 +671,7 @@ if (use_fast_calls) return function.execute(args); - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(args); } @@ -818,7 +702,7 @@ out._writeString(String.valueOf(count)); out._writeString(": "); - pprint(s.toList(), out.getCharPos(), out); + pprint(s.frameToList(), out.getCharPos(), out); out.terpri(); out._finishOutput(); if (limit > 0 && ++count == limit) @@ -840,7 +724,7 @@ try { StackFrame s = stack; while (s != null) { - result = result.push(s.toList()); + result = result.push(s.frameToList()); if (limit > 0 && ++count == limit) break; s = s.next; @@ -857,10 +741,12 @@ { StackFrame s = stack; while (s != null) { - LispObject operator = s.operator; - if (operator != null) - operator.incrementCallCount(); - s = s.next; + if (s instanceof LispStackFrame) { + LispObject operator = ((LispStackFrame)s).operator; + if (operator != null) + operator.incrementCallCount(); + } + s = s.getNext(); } } @@ -1122,7 +1008,7 @@ // ### backtrace-as-list private static final Primitive BACKTRACE_AS_LIST = - new Primitive("backtrace-as-list", PACKAGE_EXT, true, "", + new Primitive("backtrace-as-list", PACKAGE_SYS, true, "", "Returns a backtrace of the invoking thread as a list.") { @Override @@ -1136,6 +1022,37 @@ } }; + // ### 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]).frameToString(); + } + }; + + // ### 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]).frameToList(); + } + }; + + static { //FIXME: this block has been added for pre-0.16 compatibility // and can be removed the latest at release 0.22 diff -r ae68bf89ae8c src/org/armedbear/lisp/StackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/StackFrame.java Thu Jul 30 11:48:43 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 frameToList() throws ConditionThrowable; + public abstract SimpleString frameToString() throws ConditionThrowable; +} diff -r ae68bf89ae8c src/org/armedbear/lisp/Symbol.java --- a/src/org/armedbear/lisp/Symbol.java Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/Symbol.java Thu Jul 30 11:48:43 2009 +0200 @@ -3032,6 +3032,13 @@ 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_ = PACKAGE_EXT.addExternalSymbol("*INSPECTOR-HOOK*"); diff -r ae68bf89ae8c src/org/armedbear/lisp/debug.lisp --- a/src/org/armedbear/lisp/debug.lisp Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/debug.lisp Thu Jul 30 11:48:43 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-as-list))) (when *debugger-hook* (let ((hook-function *debugger-hook*) (*debugger-hook* nil)) diff -r ae68bf89ae8c src/org/armedbear/lisp/signal.lisp --- a/src/org/armedbear/lisp/signal.lisp Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/signal.lisp Thu Jul 30 11:48:43 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-as-list))) (break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)." condition)))) (loop diff -r ae68bf89ae8c src/org/armedbear/lisp/top-level.lisp --- a/src/org/armedbear/lisp/top-level.lisp Wed Jul 29 21:56:39 2009 +0200 +++ b/src/org/armedbear/lisp/top-level.lisp Thu Jul 30 11:48:43 2009 +0200 @@ -102,6 +102,19 @@ (%format *debug-io* "~A~%" s)) (show-restarts (compute-restarts) *debug-io*))) +(defun print-frame (frame stream &key prefix) + (when prefix + (write-string prefix stream)) + (when (not (consp frame)) + (setf frame (sys:frame-to-list frame))) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (ignore-errors + (prin1 (car frame) stream) + (let ((args (cdr frame))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args)))))) + (defun backtrace-command (args) (let ((count (or (and args (ignore-errors (parse-integer args))) 8)) @@ -113,14 +126,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 +142,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)))