diff -r f50bedcc83f6 build-from-lisp.sh --- a/src/org/armedbear/lisp/BuiltInClass.java Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/BuiltInClass.java Fri Jul 31 19:48:24 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 f50bedcc83f6 src/org/armedbear/lisp/JavaStackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/JavaStackFrame.java Fri Jul 31 19:48:24 2009 +0200 @@ -0,0 +1,50 @@ +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 f50bedcc83f6 src/org/armedbear/lisp/Lisp.java --- a/src/org/armedbear/lisp/Lisp.java Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/Lisp.java Fri Jul 31 19:48:24 2009 +0200 @@ -320,15 +320,40 @@ } }; + 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 i = 0; + for (StackTraceElement frame : frames) { + if (frame.getClassName().startsWith("org.armedbear.lisp.Primitive")) + break; + i++; + } + // Do not include the first three frames: + // Thread.getStackTrace, LispThread.getJavaStackTrace, + // Lisp.pushJavaStackFrames. + while (i > 2) { + thread.pushStackFrame(new JavaStackFrame(frames[i])); + i--; + } + } + + 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 +877,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 f50bedcc83f6 src/org/armedbear/lisp/LispStackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/LispStackFrame.java Fri Jul 31 19:48:24 2009 +0200 @@ -0,0 +1,117 @@ +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 f50bedcc83f6 src/org/armedbear/lisp/LispThread.java --- a/src/org/armedbear/lisp/LispThread.java Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/LispThread.java Fri Jul 31 19:48:24 2009 +0200 @@ -2,7 +2,7 @@ * LispThread.java * * Copyright (C) 2003-2007 Peter Graves - * $Id: LispThread.java 12077 2009-07-29 19:56:39Z ehuelsmann $ + * $Id: LispThread.java 12066 2009-07-27 14:11:30Z vvoutilainen $ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -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 @@ -556,44 +467,17 @@ private void doProfiling() throws ConditionThrowable { - if (sampleNow) - Profiler.sample(this); + if (profiling && sampling) { + if (sampleNow) + 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 +498,7 @@ if (use_fast_calls) return function.execute(); - pushStackFrame(function); + pushStackFrame(new LispStackFrame(function)); try { return function.execute(); } @@ -631,7 +515,7 @@ if (use_fast_calls) return function.execute(arg); - pushStackFrame(function, arg); + pushStackFrame(new LispStackFrame(function, arg)); try { return function.execute(arg); } @@ -649,7 +533,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 +551,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 +570,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 +589,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 +610,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 +632,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 +655,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 +673,7 @@ if (use_fast_calls) return function.execute(args); - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(args); } @@ -818,7 +704,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 +726,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 +743,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 +1010,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 +1024,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 f50bedcc83f6 src/org/armedbear/lisp/Profiler.java --- a/src/org/armedbear/lisp/Profiler.java Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/Profiler.java Fri Jul 31 19:48:24 2009 +0200 @@ -2,7 +2,7 @@ * Profiler.java * * Copyright (C) 2003-2005 Peter Graves - * $Id: Profiler.java 12076 2009-07-29 19:54:50Z ehuelsmann $ + * $Id: Profiler.java 12074 2009-07-29 09:15:14Z ehuelsmann $ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -47,7 +47,6 @@ private static final Runnable profilerRunnable = new Runnable() { public void run() { - profiling = true; // make sure we don't fall through on the first iteration while (profiling) { sampleNow = true; try { @@ -113,6 +112,7 @@ new Thread(profilerRunnable).start(); } out._writeLine("; Profiler started."); + profiling = true; } return thread.nothing(); } diff -r f50bedcc83f6 src/org/armedbear/lisp/StackFrame.java --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/org/armedbear/lisp/StackFrame.java Fri Jul 31 19:48:24 2009 +0200 @@ -0,0 +1,28 @@ +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 f50bedcc83f6 src/org/armedbear/lisp/Symbol.java --- a/src/org/armedbear/lisp/Symbol.java Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/Symbol.java Fri Jul 31 19:48:24 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 f50bedcc83f6 src/org/armedbear/lisp/debug.lisp --- a/src/org/armedbear/lisp/debug.lisp Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/debug.lisp Fri Jul 31 19:48:24 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 f50bedcc83f6 src/org/armedbear/lisp/defstruct.lisp --- a/src/org/armedbear/lisp/defstruct.lisp Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/defstruct.lisp Fri Jul 31 19:48:24 2009 +0200 @@ -1,7 +1,7 @@ ;;; defstruct.lisp ;;; ;;; Copyright (C) 2003-2007 Peter Graves -;;; $Id: defstruct.lisp 12078 2009-07-30 22:49:28Z ehuelsmann $ +;;; $Id: defstruct.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License @@ -113,7 +113,6 @@ (defvar *dd-copier*) (defvar *dd-include*) (defvar *dd-type*) -(defvar *dd-default-slot-type* t) (defvar *dd-named*) (defvar *dd-initial-offset*) (defvar *dd-predicate*) @@ -339,9 +338,7 @@ ((or (eq *dd-type* 'vector) (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) `((declaim (ftype (function * ,type) ,accessor-name)) - (defun ,accessor-name (instance) (aref instance ,index)) - (define-source-transform ,accessor-name (instance) - `(aref (truly-the ,',*dd-type* ,instance) ,,index)))) + (defun ,accessor-name (instance) (aref instance ,index)))) (t `((declaim (ftype (function * ,type) ,accessor-name)) (defun ,accessor-name (instance) (structure-ref instance ,index)) @@ -363,9 +360,7 @@ ((or (eq *dd-type* 'vector) (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) `((defun (setf ,accessor-name) (value instance) - (aset instance ,index value)) - (define-source-transform (setf ,accessor-name) (value instance) - `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value)))) + (aset instance ,index value)))) (t `((defun (setf ,accessor-name) (value instance) (structure-set instance ,index value)) @@ -439,10 +434,7 @@ (:print-object (setf *dd-print-object* option)) (:type - (setf *dd-type* (cadr option)) - (when (and (consp *dd-type*) (eq (car *dd-type*) 'vector)) - (unless (eq (second *dd-type*) '*) - (setf *dd-default-slot-type* (second *dd-type*))))))) + (setf *dd-type* (cadr option))))) (defun parse-name-and-options (name-and-options) (setf *dd-name* (the symbol (car name-and-options))) @@ -502,7 +494,6 @@ (*dd-copier* nil) (*dd-include* nil) (*dd-type* nil) - (*dd-default-slot-type* t) (*dd-named* nil) (*dd-initial-offset* nil) (*dd-predicate* nil) @@ -534,13 +525,7 @@ :name name :reader reader :initform initform - (cond - ((atom slot) - (list :type *dd-default-slot-type*)) - ((getf (cddr slot) :type) - (cddr slot)) - (t - (list* :type *dd-default-slot-type* (cddr slot))))))) + (if (atom slot) nil (cddr slot))))) (push dsd *dd-direct-slots*))) (setf *dd-direct-slots* (nreverse *dd-direct-slots*)) (let ((index 0)) diff -r f50bedcc83f6 src/org/armedbear/lisp/signal.lisp --- a/src/org/armedbear/lisp/signal.lisp Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/signal.lisp Fri Jul 31 19:48:24 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 f50bedcc83f6 src/org/armedbear/lisp/top-level.lisp --- a/src/org/armedbear/lisp/top-level.lisp Fri Jul 31 00:49:28 2009 +0200 +++ b/src/org/armedbear/lisp/top-level.lisp Fri Jul 31 19:48:24 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)))