contrib/gdb-7/gdb/guile/lib/gdb/init.scm

   1 ;; Scheme side of the gdb module.
   2 ;;
   3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
   4 ;;
   5 ;; This file is part of GDB.
   6 ;;
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 3 of the License, or
  10 ;; (at your option) any later version.
  11 ;;
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;; This file is included by (gdb).
  21
  22 ;; The original i/o ports.  In case the user wants them back.
  23 (define %orig-input-port #f)
  24 (define %orig-output-port #f)
  25 (define %orig-error-port #f)
  26
  27 ;; Keys for GDB-generated exceptions.
  28 ;; gdb:with-stack is handled separately.
  29
  30 (define %exception-keys '(gdb:error
  31                           gdb:invalid-object-error
  32                           gdb:memory-error
  33                           gdb:pp-type-error
  34                           gdb:user-error))
  35
  36 ;; Printer for gdb exceptions, used when Scheme tries to print them directly.
  37
  38 (define (%exception-printer port key args default-printer)
  39   (apply (case-lambda
  40           ((subr msg args . rest)
  41            (if subr
  42                (format port "In procedure ~a: " subr))
  43            (apply format port msg (or args '())))
  44           (_ (default-printer)))
  45          args))
  46
  47 ;; Print the message part of a gdb:with-stack exception.
  48 ;; The arg list is the way it is because it's passed to set-exception-printer!.
  49 ;; We don't print a backtrace here because Guile will have already printed a
  50 ;; backtrace.
  51
  52 (define (%with-stack-exception-printer port key args default-printer)
  53   (let ((real-key (car args))
  54         (real-args (cddr args)))
  55     (%exception-printer port real-key real-args default-printer)))
  56
  57 ;; Copy of Guile's print-exception that tweaks the output for our purposes.
  58 ;; TODO: It's not clear the tweaking is still necessary.
  59
  60 (define (%print-exception-message-worker port key args)
  61   (define (default-printer)
  62     (format port "Throw to key `~a' with args `~s'." key args))
  63   (format port "ERROR: ")
  64   ;; Pass #t for tag to catch all errors.
  65   (catch #t
  66          (lambda ()
  67            (%exception-printer port key args default-printer))
  68          (lambda (k . args)
  69            (format port "Error while printing gdb exception: ~a ~s."
  70                    k args)))
  71   (newline port)
  72   (force-output port))
  73
  74 ;; Called from the C code to print an exception.
  75 ;; Guile prints them a little differently than we want.
  76 ;; See boot-9.scm:print-exception.
  77
  78 (define (%print-exception-message port frame key args)
  79   (cond ((memq key %exception-keys)
  80          (%print-exception-message-worker port key args))
  81         (else
  82          (print-exception port frame key args)))
  83   *unspecified*)
  84
  85 ;; Called from the C code to print an exception according to the setting
  86 ;; of "guile print-stack".
  87 ;;
  88 ;; If PORT is #f, use the standard error port.
  89 ;; If STACK is #f, never print the stack, regardless of whether printing it
  90 ;; is enabled.  If STACK is #t, then print it if it is contained in ARGS
  91 ;; (i.e., KEY is gdb:with-stack).  Otherwise STACK is the result of calling
  92 ;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
  93 ;; KEY is gdb:with-stack).
  94 ;; KEY, ARGS are the standard arguments to scm_throw, et.al.
  95
  96 (define (%print-exception-with-stack port stack key args)
  97   (let ((style (%exception-print-style)))
  98     (if (not (eq? style 'none))
  99         (let ((error-port (current-error-port))
 100               (frame #f))
 101           (if (not port)
 102               (set! port error-port))
 103           (if (eq? port error-port)
 104               (begin
 105                 (force-output (current-output-port))
 106                 ;; In case the current output port is not gdb's output port.
 107                 (force-output (output-port))))
 108
 109           ;; If the exception is gdb:with-stack, unwrap it to get the stack and
 110           ;; underlying exception.  If the caller happens to pass in a stack,
 111           ;; we ignore it and use the one in ARGS instead.
 112           (if (eq? key 'gdb:with-stack)
 113               (begin
 114                 (set! key (car args))
 115                 (if stack
 116                     (set! stack (cadr args)))
 117                 (set! args (cddr args))))
 118
 119           ;; If caller wanted a stack and there isn't one, disable backtracing.
 120           (if (eq? stack #t)
 121               (set! stack #f))
 122           ;; At this point if stack is true, then it is assumed to be a stack.
 123           (if stack
 124               (set! frame (stack-ref stack 0)))
 125
 126           (if (and (eq? style 'full) stack)
 127               (begin
 128                 ;; This is derived from libguile/throw.c:handler_message.
 129                 ;; We include "Guile" in "Guile Backtrace" whereas the Guile
 130                 ;; version does not so that tests can know it's us printing
 131                 ;; the backtrace.  Plus it could help beginners.
 132                 (display "Guile Backtrace:\n" port)
 133                 (display-backtrace stack port #f #f '())
 134                 (newline port)))
 135
 136           (%print-exception-message port frame key args)))))
 137
 138 ;; Internal utility called during startup to initialize the Scheme side of
 139 ;; GDB+Guile.
 140
 141 (define (%initialize!)
 142   (for-each (lambda (key)
 143               (set-exception-printer! key %exception-printer))
 144             %exception-keys)
 145   (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
 146
 147   (set! %orig-input-port (set-current-input-port (input-port)))
 148   (set! %orig-output-port (set-current-output-port (output-port)))
 149   (set! %orig-error-port (set-current-error-port (error-port))))
 150
 151 ;; Dummy routine to silence "possibly unused local top-level variable"
 152 ;; warnings from the compiler.
 153
 154 (define-public (%silence-compiler-warnings%)
 155   (list %print-exception-with-stack %initialize!))
 156 \f
 157 ;; Public routines.
 158
 159 (define-public (orig-input-port) %orig-input-port)
 160 (define-public (orig-output-port) %orig-output-port)
 161 (define-public (orig-error-port) %orig-error-port)
 162
 163 ;; Utility to throw gdb:user-error for use in writing gdb commands.
 164 ;; The requirements for the arguments to "throw" are a bit obscure,
 165 ;; so give the user something simpler.
 166
 167 (define-public (throw-user-error message . args)
 168   (throw 'gdb:user-error #f message args))