Index: src/org/armedbear/lisp/AbstractStackFrame.java =================================================================== --- src/org/armedbear/lisp/AbstractStackFrame.java (revision 0) +++ src/org/armedbear/lisp/AbstractStackFrame.java (revision 0) @@ -0,0 +1,18 @@ +package org.armedbear.lisp; + +public abstract class AbstractStackFrame 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); + } + + public abstract LispObject frameToList() throws ConditionThrowable; + public abstract SimpleString frameToString() throws ConditionThrowable; + +} Index: src/org/armedbear/lisp/LispStackFrame.java =================================================================== --- src/org/armedbear/lisp/LispStackFrame.java (revision 0) +++ src/org/armedbear/lisp/LispStackFrame.java (revision 0) @@ -0,0 +1,114 @@ +package org.armedbear.lisp; + +public class LispStackFrame extends AbstractStackFrame +{ + 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; + this.args = new LispObject[args.length]; + for (int i = args.length; i-- > 0;) + this.args[i] = args[i]; + } + + @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 = 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); + } + + public SimpleString frameToString() throws ConditionThrowable { + return new SimpleString(frameToList().writeToString()); + } +} Index: src/org/armedbear/lisp/JavaStackFrame.java =================================================================== --- src/org/armedbear/lisp/JavaStackFrame.java (revision 0) +++ src/org/armedbear/lisp/JavaStackFrame.java (revision 0) @@ -0,0 +1,41 @@ +package org.armedbear.lisp; + +public class JavaStackFrame extends AbstractStackFrame +{ + 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); + } + + + public LispObject frameToList() throws ConditionThrowable + { + // Punt for now + return NIL; + } + + public SimpleString frameToString() throws ConditionThrowable { + return new SimpleString(javaFrame.toString()); + } +} \ No newline at end of file Index: src/org/armedbear/lisp/LispThread.java =================================================================== --- src/org/armedbear/lisp/LispThread.java (revision 12040) +++ src/org/armedbear/lisp/LispThread.java (working copy) @@ -111,12 +111,16 @@ javaThread.setName(name.getStringValue()); } catch (ConditionThrowable ex) { Debug.trace("Failed to set thread name:"); - Debug.trace(ex); + Debug.trace(ex); } javaThread.setDaemon(true); javaThread.start(); } + public StackTraceElement[] getJavaStackTrace() { + return javaThread.getStackTrace(); + } + @Override public LispObject typeOf() { @@ -447,95 +451,6 @@ tag.writeToString() + ".")); } - private static class StackFrame extends LispObject - { - public final LispObject operator; - private final LispObject first; - private final LispObject second; - private final LispObject third; - private final LispObject[] args; - - public StackFrame(LispObject operator) - { - this.operator = operator; - first = null; - second = null; - third = null; - args = null; - } - - public StackFrame(LispObject operator, LispObject arg) - { - this.operator = operator; - first = arg; - second = null; - third = null; - args = null; - } - - public StackFrame(LispObject operator, LispObject first, - LispObject second) - { - this.operator = operator; - this.first = first; - this.second = second; - third = null; - args = null; - } - - public StackFrame(LispObject operator, LispObject first, - LispObject second, LispObject third) - { - this.operator = operator; - this.first = first; - this.second = second; - this.third = third; - args = null; - } - - public StackFrame(LispObject operator, LispObject[] args) - { - this.operator = operator; - first = null; - second = null; - third = null; - this.args = new LispObject[args.length]; - for (int i = args.length; i-- > 0;) - this.args[i] = args[i]; - } - - 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 LispObject stack = NIL; public LispObject getStack() @@ -548,59 +463,16 @@ this.stack = stack; } - public void pushStackFrame(LispObject operator) + public void pushStackFrame(AbstractStackFrame frame) throws ConditionThrowable { - stack = new Cons((new StackFrame(operator)), stack); + stack = new Cons(frame, stack); if (profiling && sampling) { if (sampleNow) Profiler.sample(this); } } - public void pushStackFrame(LispObject operator, LispObject arg) - throws ConditionThrowable - { - stack = new Cons((new StackFrame(operator, arg)), stack); - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - } - - public void pushStackFrame(LispObject operator, LispObject first, - LispObject second) - throws ConditionThrowable - { - stack = new Cons((new StackFrame(operator, first, second)), stack); - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - } - - public void pushStackFrame(LispObject operator, LispObject first, - LispObject second, LispObject third) - throws ConditionThrowable - { - stack = new Cons((new StackFrame(operator, first, second, third)), - stack); - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - } - - public void pushStackFrame(LispObject operator, LispObject[] args) - throws ConditionThrowable - { - stack = new Cons((new StackFrame(operator, args)), stack); - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - } - public void resetStack() { stack = NIL; @@ -613,7 +485,7 @@ return function.execute(); LispObject oldStack = stack; - pushStackFrame(function); + pushStackFrame(new LispStackFrame(function)); try { return function.execute(); } @@ -634,7 +506,7 @@ return function.execute(arg); LispObject oldStack = stack; - pushStackFrame(function, arg); + pushStackFrame(new LispStackFrame(function, arg)); try { return function.execute(arg); } @@ -656,7 +528,7 @@ return function.execute(first, second); LispObject oldStack = stack; - pushStackFrame(function, first, second); + pushStackFrame(new LispStackFrame(function, first, second)); try { return function.execute(first, second); } @@ -678,7 +550,7 @@ return function.execute(first, second, third); LispObject oldStack = stack; - pushStackFrame(function, first, second, third); + pushStackFrame(new LispStackFrame(function, first, second, third)); try { return function.execute(first, second, third); } @@ -706,7 +578,7 @@ args[1] = second; args[2] = third; args[3] = fourth; - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(first, second, third, fourth); } @@ -735,7 +607,7 @@ args[2] = third; args[3] = fourth; args[4] = fifth; - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(first, second, third, fourth, fifth); } @@ -766,7 +638,7 @@ args[3] = fourth; args[4] = fifth; args[5] = sixth; - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(first, second, third, fourth, fifth, sixth); } @@ -799,7 +671,7 @@ args[4] = fifth; args[5] = sixth; args[6] = seventh; - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(first, second, third, fourth, fifth, sixth, seventh); @@ -834,7 +706,7 @@ args[5] = sixth; args[6] = seventh; args[7] = eighth; - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(first, second, third, fourth, fifth, sixth, seventh, eighth); @@ -855,7 +727,7 @@ return function.execute(args); LispObject oldStack = stack; - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(args); } @@ -886,8 +758,8 @@ out._writeString(" "); out._writeString(String.valueOf(count)); out._writeString(": "); - StackFrame frame = (StackFrame) stack.car(); - pprint(frame.toList(), out.getCharPos(), out); + AbstractStackFrame frame = (AbstractStackFrame) stack.car(); + pprint(frame.frameToList(), out.getCharPos(), out); out.terpri(); out._finishOutput(); if (limit > 0 && ++count == limit) @@ -909,9 +781,9 @@ try { LispObject s = stack; while (s != NIL) { - StackFrame frame = (StackFrame) s.car(); + AbstractStackFrame frame = (AbstractStackFrame) s.car(); if (frame != null) { - result = result.push(frame.toList()); + result = result.push(frame); if (limit > 0 && ++count == limit) break; } @@ -924,16 +796,18 @@ } return result.nreverse(); } - + public void incrementCallCounts() throws ConditionThrowable { LispObject s = stack; while (s != NIL) { - StackFrame frame = (StackFrame) s.car(); - if (frame != null) { - LispObject operator = frame.operator; - if (operator != null) - operator.incrementCallCount(); + if (s.car() instanceof LispStackFrame) { + LispStackFrame frame = (LispStackFrame) s.car(); + if (frame != null) { + LispObject operator = frame.operator; + if (operator != null) + operator.incrementCallCount(); + } } s = s.cdr(); } @@ -1197,7 +1071,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 @@ -1211,6 +1085,36 @@ } }; + // ### 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 Index: src/org/armedbear/lisp/Lisp.java =================================================================== --- src/org/armedbear/lisp/Lisp.java (revision 12040) +++ src/org/armedbear/lisp/Lisp.java (working copy) @@ -94,6 +94,11 @@ PACKAGE_CL_USER.usePackage(PACKAGE_CL); PACKAGE_CL_USER.usePackage(PACKAGE_EXT); PACKAGE_CL_USER.usePackage(PACKAGE_JAVA); + PACKAGE_CL_USER.usePackage(PACKAGE_THREADS); + + // FIXME: The following packages all have to use EXT because + // of EXT:AUTOLOAD and autoload.lisp. + PACKAGE_SYS.addNickname("SYS"); PACKAGE_SYS.usePackage(PACKAGE_CL); PACKAGE_SYS.usePackage(PACKAGE_EXT); @@ -105,6 +110,7 @@ PACKAGE_TPL.usePackage(PACKAGE_EXT); PACKAGE_EXT.addNickname("EXT"); PACKAGE_EXT.usePackage(PACKAGE_CL); + // FIXME: To be removed. PACKAGE_EXT.usePackage(PACKAGE_THREADS); PACKAGE_JVM.usePackage(PACKAGE_CL); PACKAGE_JVM.usePackage(PACKAGE_EXT); @@ -118,6 +124,8 @@ PACKAGE_LISP.usePackage(PACKAGE_CL); PACKAGE_LISP.usePackage(PACKAGE_EXT); PACKAGE_LISP.usePackage(PACKAGE_SYS); + PACKAGE_THREADS.usePackage(PACKAGE_CL); + PACKAGE_THREADS.usePackage(PACKAGE_EXT); } catch (Throwable t) { @@ -140,7 +148,7 @@ throws ConditionThrowable { LispObject stack = thread.getStack(); - thread.pushStackFrame(fun, args); + thread.pushStackFrame(new LispStackFrame(fun, args)); thread._values = null; LispObject result; if (profiling) @@ -339,15 +347,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 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); } @@ -871,6 +903,14 @@ type_error(obj, Symbol.SINGLE_FLOAT); } + public static final AbstractStackFrame checkStackFrame(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof AbstractStackFrame) + return (AbstractStackFrame) obj; + return (AbstractStackFrame)// Not reached. + type_error(obj, Symbol.STACK_FRAME); + } static { Index: src/org/armedbear/lisp/Symbol.java =================================================================== --- src/org/armedbear/lisp/Symbol.java (revision 12040) +++ src/org/armedbear/lisp/Symbol.java (working copy) @@ -841,7 +841,6 @@ if ((fun = function) == null) return undefinedFunction(list(first, second, third, fourth, fifth, sixth)); - return fun.execute(first, second, third, fourth, fifth, sixth); } @@ -3034,6 +3033,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*"); Index: src/org/armedbear/lisp/BuiltInClass.java =================================================================== --- src/org/armedbear/lisp/BuiltInClass.java (revision 12040) +++ src/org/armedbear/lisp/BuiltInClass.java (working copy) @@ -144,6 +144,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 @@ -276,6 +280,14 @@ 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 Index: src/org/armedbear/lisp/debug.lisp =================================================================== --- src/org/armedbear/lisp/debug.lisp (revision 12040) +++ src/org/armedbear/lisp/debug.lisp (working copy) @@ -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)) Index: src/org/armedbear/lisp/signal.lisp =================================================================== --- src/org/armedbear/lisp/signal.lisp (revision 12040) +++ src/org/armedbear/lisp/signal.lisp (working copy) @@ -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 Index: src/org/armedbear/lisp/top-level.lisp =================================================================== --- src/org/armedbear/lisp/top-level.lisp (revision 12040) +++ src/org/armedbear/lisp/top-level.lisp (working copy) @@ -102,6 +102,22 @@ (%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 +129,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 +145,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)))