1;; Scheme side of the gdb module. 2;; 3;; Copyright (C) 2014-2020 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 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)) 169