gdb/guile/lib/gdb/init.scm

   1 ;; Scheme side of the gdb module.
   2 ;;
   3 ;; Copyright (C) 2014 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 (define-module (gdb init)
  21   #:use-module (gdb))
  22
  23 (define-public SCM_ARG1 1)
  24 (define-public SCM_ARG2 2)
  25
  26 ;; The original i/o ports.  In case the user wants them back.
  27 (define %orig-input-port #f)
  28 (define %orig-output-port #f)
  29 (define %orig-error-port #f)
  30
  31 ;; %exception-print-style is exported as "private" by gdb.
  32 (define %exception-print-style (@@ (gdb) %exception-print-style))
  33
  34 ;; Keys for GDB-generated exceptions.
  35 ;; gdb:with-stack is handled separately.
  36
  37 (define %exception-keys '(gdb:error
  38                           gdb:invalid-object-error
  39                           gdb:memory-error
  40                           gdb:pp-type-error))
  41
  42 ;; Printer for gdb exceptions, used when Scheme tries to print them directly.
  43
  44 (define (%exception-printer port key args default-printer)
  45   (apply (case-lambda
  46           ((subr msg args . rest)
  47            (if subr
  48                (format port "In procedure ~a: " subr))
  49            (apply format port msg (or args '())))
  50           (_ (default-printer)))
  51          args))
  52
  53 ;; Print the message part of a gdb:with-stack exception.
  54 ;; The arg list is the way it is because it's passed to set-exception-printer!.
  55 ;; We don't print a backtrace here because Guile will have already printed a
  56 ;; backtrace.
  57
  58 (define (%with-stack-exception-printer port key args default-printer)
  59   (let ((real-key (car args))
  60         (real-args (cddr args)))
  61     (%exception-printer port real-key real-args default-printer)))
  62
  63 ;; Copy of Guile's print-exception that tweaks the output for our purposes.
  64 ;; TODO: It's not clear the tweaking is still necessary.
  65
  66 (define (%print-exception-message-worker port key args)
  67   (define (default-printer)
  68     (format port "Throw to key `~a' with args `~s'." key args))
  69   (format port "ERROR: ")
  70   ;; Pass #t for tag to catch all errors.
  71   (catch #t
  72          (lambda ()
  73            (%exception-printer port key args default-printer))
  74          (lambda (k . args)
  75            (format port "Error while printing gdb exception: ~a ~s."
  76                    k args)))
  77   (newline port)
  78   (force-output port))
  79
  80 ;; Called from the C code to print an exception.
  81 ;; Guile prints them a little differently than we want.
  82 ;; See boot-9.scm:print-exception.
  83
  84 (define (%print-exception-message port frame key args)
  85   (cond ((memq key %exception-keys)
  86          (%print-exception-message-worker port key args))
  87         (else
  88          (print-exception port frame key args)))
  89   *unspecified*)
  90
  91 ;; Called from the C code to print an exception according to the setting
  92 ;; of "guile print-stack".
  93 ;;
  94 ;; If PORT is #f, use the standard error port.
  95 ;; If STACK is #f, never print the stack, regardless of whether printing it
  96 ;; is enabled.  If STACK is #t, then print it if it is contained in ARGS
  97 ;; (i.e., KEY is gdb:with-stack).  Otherwise STACK is the result of calling
  98 ;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
  99 ;; KEY is gdb:with-stack).
 100 ;; KEY, ARGS are the standard arguments to scm_throw, et.al.
 101
 102 (define (%print-exception-with-stack port stack key args)
 103   (let ((style (%exception-print-style)))
 104     (if (not (eq? style 'none))
 105         (let ((error-port (current-error-port))
 106               (frame #f))
 107           (if (not port)
 108               (set! port error-port))
 109           (if (eq? port error-port)
 110               (begin
 111                 (force-output (current-output-port))
 112                 ;; In case the current output port is not gdb's output port.
 113                 (force-output (output-port))))
 114
 115           ;; If the exception is gdb:with-stack, unwrap it to get the stack and
 116           ;; underlying exception.  If the caller happens to pass in a stack,
 117           ;; we ignore it and use the one in ARGS instead.
 118           (if (eq? key 'gdb:with-stack)
 119               (begin
 120                 (set! key (car args))
 121                 (if stack
 122                     (set! stack (cadr args)))
 123                 (set! args (cddr args))))
 124
 125           ;; If caller wanted a stack and there isn't one, disable backtracing.
 126           (if (eq? stack #t)
 127               (set! stack #f))
 128           ;; At this point if stack is true, then it is assumed to be a stack.
 129           (if stack
 130               (set! frame (stack-ref stack 0)))
 131
 132           (if (and (eq? style 'full) stack)
 133               (begin
 134                 ;; This is derived from libguile/throw.c:handler_message.
 135                 ;; We include "Guile" in "Guile Backtrace" whereas the Guile
 136                 ;; version does not so that tests can know it's us printing
 137                 ;; the backtrace.  Plus it could help beginners.
 138                 (display "Guile Backtrace:\n" port)
 139                 (display-backtrace stack port #f #f '())
 140                 (newline port)))
 141
 142           (%print-exception-message port frame key args)))))
 143
 144 ;; Internal utility to check the type of an argument, akin to SCM_ASSERT_TYPE.
 145 ;; It's public so other gdb modules can use it.
 146
 147 (define-public (%assert-type test-result arg pos func-name)
 148   (if (not test-result)
 149       (scm-error 'wrong-type-arg func-name
 150                  "Wrong type argument in position ~a: ~s"
 151                  (list pos arg) (list arg))))
 152
 153 ;; Internal utility called during startup to initialize the Scheme side of
 154 ;; GDB+Guile.
 155
 156 (define (%initialize!)
 157   (add-to-load-path (string-append (data-directory)
 158                                    file-name-separator-string "guile"))
 159
 160   (for-each (lambda (key)
 161               (set-exception-printer! key %exception-printer))
 162             %exception-keys)
 163   (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
 164
 165   (set! %orig-input-port (set-current-input-port (input-port)))
 166   (set! %orig-output-port (set-current-output-port (output-port)))
 167   (set! %orig-error-port (set-current-error-port (error-port))))
 168 \f
 169 ;; Public routines.
 170
 171 (define-public (orig-input-port) %orig-input-port)
 172 (define-public (orig-output-port) %orig-output-port)
 173 (define-public (orig-error-port) %orig-error-port)