[Larceny-users] A useful chunk of code...

[David Rush]

Hi y'all -

Just a little paybacks for all the whingeing I've done over what has
so often turned out to be my own excess hurry during the last months.
Here's is a chunk of code which will cause your Larceny program to
dump a stack backtrace and exit instead of jumping into the debugger
REPL. There's no real rocket science here, I just dug around in the
source code until I found the hooks (which fortunately turn out to be
in the lib/Debugger directory so I don't feel *too* guilty about
re-using 'internal' code).

It may also be useful as a model for writing other sorts of error/exit
handlers. Code is below the fold...

david rush
-- 
Once you label me, you negate me
    - Soren Kierkegaard

(require 'inspect-cont)

;; The code was parameterized over the puts function to interface to some
;; highly-customized logging functionality. (lambda (s) (display s) (newline))
;; would be one standard Scheme implementation...

(define (batch/last-chance-handler puts)
  (lambda e
    (define (display-line s)
      (puts (with-output-to-string
              (lambda () (write s)))))

    (display-line `(lastchance error handler ,e))

    (let* ((error-text
            (call-with-output-string (lambda (p) (decode-error e p))))
           (stacktrace (current-continuation-structure))
           (inspector (make-continuation-inspector stacktrace))

           (summarize-frame
            (lambda (count inspector . prefix)
              (let* ((frame (inspector 'get))
                     (code  (frame 'code))
                     (class (code 'class))
                     (expr  (code 'expression))
                     (proc  (code 'procedure)))
                (display-line
                 `(frame , at prefix ,class
                         ,@(case class
                             ((system-procedure) '())
                             ((interpreted-primitive) (procedure-name proc))
                             ((interpreted-expression) expr)
                             ((compiled-procedure) (procedure-name proc))
                             (else '())))
                 ))))

           (backtrace
            (lambda (count inspector)
              (let loop ((c (inspector 'clone)))
                (let ((f (c 'get)))
                  (if (f 'same? (inspector 'get))
                      (summarize-frame 0 c "=> ")
                      (summarize-frame 0 c "   ")))
                (if (c 'down)
                    (loop c))
                )))
           )
      (display-line `(decoded error ,error-text))
      (backtrace 0 inspector)
      (exit 0)
      )))

(define (install-lastchance puts)
  (error-handler (batch/last-chance-handler puts)))