1 ;; Scheme side of the gdb module.
3 ;; Copyright (C) 2014-2018 Free Software Foundation, Inc.
5 ;; This file is part of GDB.
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.
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.
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/>.
20 ;; This file is included by (gdb).
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)
27 ;; Keys for GDB-generated exceptions.
28 ;; gdb:with-stack is handled separately.
30 (define %exception-keys '(gdb:error
31 gdb:invalid-object-error
36 ;; Printer for gdb exceptions, used when Scheme tries to print them directly.
38 (define (%exception-printer port key args default-printer)
40 ((subr msg args . rest)
42 (format port "In procedure ~a: " subr))
43 (apply format port msg (or args '())))
44 (_ (default-printer)))
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
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)))
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.
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.
67 (%exception-printer port key args default-printer))
69 (format port "Error while printing gdb exception: ~a ~s."
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.
78 (define (%print-exception-message port frame key args)
79 (cond ((memq key %exception-keys)
80 (%print-exception-message-worker port key args))
82 (print-exception port frame key args)))
85 ;; Called from the C code to print an exception according to the setting
86 ;; of "guile print-stack".
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.
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))
102 (set! port error-port))
103 (if (eq? port error-port)
105 (force-output (current-output-port))
106 ;; In case the current output port is not gdb's output port.
107 (force-output (output-port))))
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)
114 (set! key (car args))
116 (set! stack (cadr args)))
117 (set! args (cddr args))))
119 ;; If caller wanted a stack and there isn't one, disable backtracing.
122 ;; At this point if stack is true, then it is assumed to be a stack.
124 (set! frame (stack-ref stack 0)))
126 (if (and (eq? style 'full) stack)
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 '())
136 (%print-exception-message port frame key args)))))
138 ;; Internal utility called during startup to initialize the Scheme side of
141 (define (%initialize!)
142 (for-each (lambda (key)
143 (set-exception-printer! key %exception-printer))
145 (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
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))))
151 ;; Dummy routine to silence "possibly unused local top-level variable"
152 ;; warnings from the compiler.
154 (define-public (%silence-compiler-warnings%)
155 (list %print-exception-with-stack %initialize!))
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)
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.
167 (define-public (throw-user-error message . args)
168 (throw 'gdb:user-error #f message args))