diff options
author | Doug Evans <xdje42@gmail.com> | 2014-02-09 19:40:01 -0800 |
---|---|---|
committer | Doug Evans <xdje42@gmail.com> | 2014-02-09 19:40:01 -0800 |
commit | ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461 (patch) | |
tree | 4e67d95b8ea65bb36a9cade5e37df2ad6289052e /gdb/guile/lib | |
parent | 7026a7c16ee82d39e84823f8cc3097a9a940ddb2 (diff) | |
download | binutils-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.zip binutils-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.tar.gz binutils-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.tar.bz2 |
Add Guile as an extension language.
* NEWS: Mention Guile scripting.
* Makefile.in (SUBDIR_GUILE_OBS): New variable.
(SUBDIR_GUILE_SRCS, SUBDIR_GUILE_DEPS): New variables
(SUBDIR_GUILE_LDFLAGS, SUBDIR_GUILE_CFLAGS): New variables.
(INTERNAL_CPPFLAGS): Add GUILE_CPPFLAGS.
(CLIBS): Add GUILE_LIBS.
(install-guile): New rule.
(guile.o): New rule.
(scm-arch.o, scm-auto-load.o, scm-block.o): New rules.
(scm-breakpoint.o, scm-disasm.o, scm-exception.o): New rules.
(scm-frame.o, scm-iterator.o, scm-lazy-string.o): New rules.
(scm-math.o, scm-objfile.o, scm-ports.o): New rules.
(scm-pretty-print.o, scm-safe-call.o, scm-gsmob.o): New rules.
(scm-string.o, scm-symbol.o, scm-symtab.o): New rules.
(scm-type.o, scm-utils.o, scm-value.o): New rules.
* configure.ac: New option --with-guile.
* configure: Regenerate.
* config.in: Regenerate.
* auto-load.c: Remove #include "python/python.h". Add #include
"gdb/section-scripts.h".
(source_section_scripts): Handle Guile scripts.
(_initialize_auto_load): Add name of Guile objfile script to
scripts-directory help text.
* breakpoint.c (condition_command): Tweak comment to include Scheme.
* breakpoint.h (gdbscm_breakpoint_object): Add forward decl.
(struct breakpoint): New member scm_bp_object.
* defs.h (enum command_control_type): New value guile_control.
* cli/cli-cmds.c: Remove #include "python/python.h". Add #include
"extension.h".
(show_user): Update comment.
(_initialize_cli_cmds): Update help text for "show user". Update help
text for max-user-call-depth.
* cli/cli-script.c: Remove #include "python/python.h". Add #include
"extension.h".
(multi_line_command_p): Add guile_control.
(print_command_lines): Handle guile_control.
(execute_control_command, recurse_read_control_structure): Ditto.
(process_next_line): Recognize "guile" commands.
* disasm.c (gdb_disassemble_info): Make non-static.
* disasm.h: #include "dis-asm.h".
(struct gdbarch): Add forward decl.
(gdb_disassemble_info): Declare.
* extension.c: #include "guile/guile.h".
(extension_languages): Add guile.
(get_ext_lang_defn): Handle EXT_LANG_GDB.
* extension.h (enum extension_language): New value EXT_LANG_GUILE.
* gdbtypes.c (get_unsigned_type_max): New function.
(get_signed_type_minmax): New function.
* gdbtypes.h (get_unsigned_type_max): Declare.
(get_signed_type_minmax): Declare.
* guile/README: New file.
* guile/guile-internal.h: New file.
* guile/guile.c: New file.
* guile/guile.h: New file.
* guile/scm-arch.c: New file.
* guile/scm-auto-load.c: New file.
* guile/scm-block.c: New file.
* guile/scm-breakpoint.c: New file.
* guile/scm-disasm.c: New file.
* guile/scm-exception.c: New file.
* guile/scm-frame.c: New file.
* guile/scm-gsmob.c: New file.
* guile/scm-iterator.c: New file.
* guile/scm-lazy-string.c: New file.
* guile/scm-math.c: New file.
* guile/scm-objfile.c: New file.
* guile/scm-ports.c: New file.
* guile/scm-pretty-print.c: New file.
* guile/scm-safe-call.c: New file.
* guile/scm-string.c: New file.
* guile/scm-symbol.c: New file.
* guile/scm-symtab.c: New file.
* guile/scm-type.c: New file.
* guile/scm-utils.c: New file.
* guile/scm-value.c: New file.
* guile/lib/gdb.scm: New file.
* guile/lib/gdb/boot.scm: New file.
* guile/lib/gdb/experimental.scm: New file.
* guile/lib/gdb/init.scm: New file.
* guile/lib/gdb/iterator.scm: New file.
* guile/lib/gdb/printing.scm: New file.
* guile/lib/gdb/types.scm: New file.
* data-directory/Makefile.in (GUILE_SRCDIR): New variable.
(VPATH): Add $(GUILE_SRCDIR).
(GUILE_DIR): New variable.
(GUILE_INSTALL_DIR, GUILE_FILES): New variables.
(all): Add stamp-guile dependency.
(stamp-guile): New rule.
(clean-guile, install-guile, uninstall-guile): New rules.
(install-only): Add install-guile dependency.
(uninstall): Add uninstall-guile dependency.
(clean): Add clean-guile dependency.
doc/
* Makefile.in (GDB_DOC_FILES): Add guile.texi.
* gdb.texinfo (Auto-loading): Add set/show auto-load guile-scripts.
(Extending GDB): New menu entries Guile, Multiple Extension Languages.
(Guile docs): Include guile.texi.
(objfile-gdbdotext file): Add objfile-gdb.scm.
(dotdebug_gdb_scripts section): Mention Guile scripts.
(Multiple Extension Languages): New node.
* guile.texi: New file.
testsuite/
* configure.ac (AC_OUTPUT): Add gdb.guile.
* configure: Regenerate.
* lib/gdb-guile.exp: New file.
* lib/gdb.exp (get_target_charset): New function.
* gdb.base/help.exp: Update expected output from "apropos apropos".
* gdb.guile/Makefile.in: New file.
* gdb.guile/guile.exp: New file.
* gdb.guile/scm-arch.c: New file.
* gdb.guile/scm-arch.exp: New file.
* gdb.guile/scm-block.c: New file.
* gdb.guile/scm-block.exp: New file.
* gdb.guile/scm-breakpoint.c: New file.
* gdb.guile/scm-breakpoint.exp: New file.
* gdb.guile/scm-disasm.c: New file.
* gdb.guile/scm-disasm.exp: New file.
* gdb.guile/scm-equal.c: New file.
* gdb.guile/scm-equal.exp: New file.
* gdb.guile/scm-error.exp: New file.
* gdb.guile/scm-error.scm: New file.
* gdb.guile/scm-frame-args.c: New file.
* gdb.guile/scm-frame-args.exp: New file.
* gdb.guile/scm-frame-args.scm: New file.
* gdb.guile/scm-frame-inline.c: New file.
* gdb.guile/scm-frame-inline.exp: New file.
* gdb.guile/scm-frame.c: New file.
* gdb.guile/scm-frame.exp: New file.
* gdb.guile/scm-generics.exp: New file.
* gdb.guile/scm-gsmob.exp: New file.
* gdb.guile/scm-iterator.c: New file.
* gdb.guile/scm-iterator.exp: New file.
* gdb.guile/scm-math.c: New file.
* gdb.guile/scm-math.exp: New file.
* gdb.guile/scm-objfile-script-gdb.in: New file.
* gdb.guile/scm-objfile-script.c: New file.
* gdb.guile/scm-objfile-script.exp: New file.
* gdb.guile/scm-objfile.c: New file.
* gdb.guile/scm-objfile.exp: New file.
* gdb.guile/scm-ports.exp: New file.
* gdb.guile/scm-pretty-print.c: New file.
* gdb.guile/scm-pretty-print.exp: New file.
* gdb.guile/scm-pretty-print.scm: New file.
* gdb.guile/scm-section-script.c: New file.
* gdb.guile/scm-section-script.exp: New file.
* gdb.guile/scm-section-script.scm: New file.
* gdb.guile/scm-symbol.c: New file.
* gdb.guile/scm-symbol.exp: New file.
* gdb.guile/scm-symtab-2.c: New file.
* gdb.guile/scm-symtab.c: New file.
* gdb.guile/scm-symtab.exp: New file.
* gdb.guile/scm-type.c: New file.
* gdb.guile/scm-type.exp: New file.
* gdb.guile/scm-value-cc.cc: New file.
* gdb.guile/scm-value-cc.exp: New file.
* gdb.guile/scm-value.c: New file.
* gdb.guile/scm-value.exp: New file.
* gdb.guile/source2.scm: New file.
* gdb.guile/types-module.cc: New file.
* gdb.guile/types-module.exp: New file.
Diffstat (limited to 'gdb/guile/lib')
-rw-r--r-- | gdb/guile/lib/gdb.scm | 452 | ||||
-rw-r--r-- | gdb/guile/lib/gdb/boot.scm | 31 | ||||
-rw-r--r-- | gdb/guile/lib/gdb/experimental.scm | 35 | ||||
-rw-r--r-- | gdb/guile/lib/gdb/init.scm | 173 | ||||
-rw-r--r-- | gdb/guile/lib/gdb/iterator.scm | 80 | ||||
-rw-r--r-- | gdb/guile/lib/gdb/printing.scm | 52 | ||||
-rw-r--r-- | gdb/guile/lib/gdb/types.scm | 78 |
7 files changed, 901 insertions, 0 deletions
diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm new file mode 100644 index 0000000..f12769e --- /dev/null +++ b/gdb/guile/lib/gdb.scm @@ -0,0 +1,452 @@ +;; Scheme side of the gdb module. +;; +;; Copyright (C) 2014 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;; This file is loaded with scm_c_primitive_load, which is ok, but files +;; loaded with it are not compiled. So we do very little here, and do +;; most of the initialization in init.scm. + +(define-module (gdb) + ;; The version of the (gdb) module as (major minor). + ;; Incompatible changes bump the major version. + ;; Other changes bump the minor version. + ;; It's not clear whether we need a patch-level as well, but this can + ;; be added later if necessary. + ;; This is not the GDB version on purpose. This version tracks the Scheme + ;; gdb module version. + ;; TODO: Change to (1 0) when ready. + #:version (0 1)) + +;; Export the bits provided by the C side. +;; This is so that the compiler can see the exports when +;; other code uses this module. +;; TODO: Generating this list would be nice, but it would require an addition +;; to the GDB build system. Still, I think it's worth it. + +(export + + ;; guile.c + + execute + data-directory + gdb-version + host-config + target-config + + ;; scm-arch.c + + arch? + current-arch + arch-name + arch-charset + arch-wide-charset + + arch-void-type + arch-char-type + arch-short-type + arch-int-type + arch-long-type + + arch-schar-type + arch-uchar-type + arch-ushort-type + arch-uint-type + arch-ulong-type + arch-float-type + arch-double-type + arch-longdouble-type + arch-bool-type + arch-longlong-type + arch-ulonglong-type + + arch-int8-type + arch-uint8-type + arch-int16-type + arch-uint16-type + arch-int32-type + arch-uint32-type + arch-int64-type + arch-uint64-type + + ;; scm-block.c + + block? + block-valid? + block-start + block-end + block-function + block-superblock + block-global-block + block-static-block + block-global? + block-static? + block-symbols + make-block-symbols-iterator + block-symbols-progress? + lookup-block + + ;; scm-breakpoint.c + + BP_NONE + BP_BREAKPOINT + BP_WATCHPOINT + BP_HARDWARE_WATCHPOINT + BP_READ_WATCHPOINT + BP_ACCESS_WATCHPOINT + + WP_READ + WP_WRITE + WP_ACCESS + + make-breakpoint + breakpoint-delete! + breakpoints + breakpoint? + breakpoint-valid? + breakpoint-number + breakpoint-type + brekapoint-visible? + breakpoint-location + breakpoint-expression + breakpoint-enabled? + set-breakpoint-enabled! + breakpoint-silent? + set-breakpoint-silent! + breakpoint-ignore-count + set-breakpoint-ignore-count! + breakpoint-hit-count + set-breakpoint-hit-count! + breakpoint-thread + set-breakpoint-thread! + breakpoint-task + set-breakpoint-task! + breakpoint-condition + set-breakpoint-condition! + breakpoint-stop + set-breakpoint-stop! + breakpoint-commands + + ;; scm-disasm.c + + arch-disassemble + + ;; scm-exception.c + + make-exception + exception? + exception-key + exception-args + + ;; scm-frame.c + + NORMAL_FRAME + DUMMY_FRAME + INLINE_FRAME + TAILCALL_FRAME + SIGTRAMP_FRAME + ARCH_FRAME + SENTINEL_FRAME + + FRAME_UNWIND_NO_REASON + FRAME_UNWIND_NULL_ID + FRAME_UNWIND_OUTERMOST + FRAME_UNWIND_UNAVAILABLE + FRAME_UNWIND_INNER_ID + FRAME_UNWIND_SAME_ID + FRAME_UNWIND_NO_SAVED_PC + + frame? + frame-valid? + frame-name + frame-type + frame-arch + frame-unwind-stop-reason + frame-pc + frame-block + frame-function + frame-older + frame-newer + frame-sal + frame-read-var + frame-select + newest-frame + selected-frame + unwind-stop-reason-string + + ;; scm-iterator.c + + make-iterator + iterator? + iterator-object + iterator-progress + set-iterator-progress! + iterator-next! + end-of-iteration + end-of-iteration? + + ;; scm-lazy-string.c + ;; FIXME: Where's the constructor? + + lazy-string? + lazy-string-address + lazy-string-length + lazy-string-encoding + lazy-string-type + lazy-string->value + + ;; scm-math.c + + valid-add + value-sub + value-mul + value-div + value-rem + value-mod + value-pow + value-not + value-neg + value-pos + value-abs + value-lsh + value-rsh + value-min + value-max + value-lognot + value-logand + value-logior + value-logxor + value=? + value<? + value<=? + value>? + value>=? + + ;; scm-objfile.c + + objfile? + objfile-valid? + objfile-filename + objfile-pretty-printers + set-objfile-pretty-printers! + current-objfile + objfiles + + ;; scm-ports.c + + input-port + output-port + error-port + stdio-port? + open-memory + memory-port? + memory-port-range + memory-port-read-buffer-size + set-memory-port-read-buffer-size! + memory-port-write-buffer-size + set-memory-port-write-buffer-size! + ;; with-gdb-output-to-port, with-gdb-error-to-port are in experimental.scm. + + ;; scm-pretty-print.c + + make-pretty-printer + pretty-printer? + pretty-printer-enabled? + set-pretty-printer-enabled! + make-pretty-printer-worker + pretty-printer-worker? + + ;; scm-smob.c + + gsmob-kind + gsmob-property + set-gsmob-property! + gsmob-has-property? + gsmob-properties + + ;; scm-string.c + + string->argv + + ;; scm-symbol.c + + SYMBOL_LOC_UNDEF + SYMBOL_LOC_CONST + SYMBOL_LOC_STATIC + SYMBOL_LOC_REGISTER + SYMBOL_LOC_ARG + SYMBOL_LOC_REF_ARG + SYMBOL_LOC_LOCAL + SYMBOL_LOC_TYPEDEF + SYMBOL_LOC_LABEL + SYMBOL_LOC_BLOCK + SYMBOL_LOC_CONST_BYTES + SYMBOL_LOC_UNRESOLVED + SYMBOL_LOC_OPTIMIZED_OUT + SYMBOL_LOC_COMPUTED + SYMBOL_LOC_REGPARM_ADDR + + SYMBOL_UNDEF_DOMAIN + SYMBOL_VAR_DOMAIN + SYMBOL_STRUCT_DOMAIN + SYMBOL_LABEL_DOMAIN + SYMBOL_VARIABLES_DOMAIN + SYMBOL_FUNCTIONS_DOMAIN + SYMBOL_TYPES_DOMAIN + + symbol? + symbol-valid? + symbol-type + symbol-symtab + symbol-line + symbol-name + symbol-linkage-name + symbol-print-name + symbol-addr-class + symbol-argument? + symbol-constant? + symbol-function? + symbol-variable? + symbol-needs-frame? + symbol-value + lookup-symbol + lookup-global-symbol + + ;; scm-symtab.c + + symtab? + symtab-valid? + symtab-filename + symtab-fullname + symtab-objfile + symtab-global-block + symtab-static-block + sal? + sal-valid? + sal-symtab + sal-line + sal-pc + sal-last + find-pc-line + + ;; scm-type.c + + TYPE_CODE_BITSTRING + TYPE_CODE_PTR + TYPE_CODE_ARRAY + TYPE_CODE_STRUCT + TYPE_CODE_UNION + TYPE_CODE_ENUM + TYPE_CODE_FLAGS + TYPE_CODE_FUNC + TYPE_CODE_INT + TYPE_CODE_FLT + TYPE_CODE_VOID + TYPE_CODE_SET + TYPE_CODE_RANGE + TYPE_CODE_STRING + TYPE_CODE_ERROR + TYPE_CODE_METHOD + TYPE_CODE_METHODPTR + TYPE_CODE_MEMBERPTR + TYPE_CODE_REF + TYPE_CODE_CHAR + TYPE_CODE_BOOL + TYPE_CODE_COMPLEX + TYPE_CODE_TYPEDEF + TYPE_CODE_NAMESPACE + TYPE_CODE_DECFLOAT + TYPE_CODE_INTERNAL_FUNCTION + + type? + lookup-type + type-code + type-fields + type-tag + type-sizeof + type-strip-typedefs + type-array + type-vector + type-pointer + type-range + type-reference + type-target + type-const + type-volatile + type-unqualified + type-name + type-num-fields + type-fields + make-field-iterator + type-field + type-has-field? + field? + field-name + field-type + field-enumval + field-bitpos + field-bitsize + field-artificial? + field-baseclass? + + ;; scm-value.c + + value? + make-value + value-optimized-out? + value-address + value-type + value-dynamic-type + value-cast + value-dynamic-cast + value-reinterpret-cast + value-dereference + value-referenced-value + value-field + value-subscript + value-call + value->bool + value->integer + value->real + value->bytevector + value->string + value->lazy-string + value-lazy? + make-lazy-value + value-fetch-lazy! + value-print + parse-and-eval + history-ref +) + +;; Load the rest of the Scheme side. +;; data-directory is provided by the C code. + +(add-to-load-path + (string-append (data-directory) file-name-separator-string "guile")) + +(use-modules ((gdb init))) + +;; These come from other files, but they're really part of this module. + +(re-export + + ;; init.scm + orig-input-port + orig-output-port + orig-error-port +) diff --git a/gdb/guile/lib/gdb/boot.scm b/gdb/guile/lib/gdb/boot.scm new file mode 100644 index 0000000..cf7d305 --- /dev/null +++ b/gdb/guile/lib/gdb/boot.scm @@ -0,0 +1,31 @@ +;; Bootstrap the Scheme side of the gdb module. +;; +;; Copyright (C) 2014 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;; This file is loaded with scm_c_primitive_load, which is ok, but files +;; loaded with it are not compiled. So we do very little here, and do +;; most of the initialization elsewhere. + +;; data-directory is provided by the C code. +(load (string-append + (data-directory) file-name-separator-string "guile" + file-name-separator-string "gdb.scm")) + +;; Now that the Scheme side support is loaded, initialize it. +(let ((init-proc (@@ (gdb init) %initialize!))) + (init-proc)) diff --git a/gdb/guile/lib/gdb/experimental.scm b/gdb/guile/lib/gdb/experimental.scm new file mode 100644 index 0000000..ffded84 --- /dev/null +++ b/gdb/guile/lib/gdb/experimental.scm @@ -0,0 +1,35 @@ +;; Various experimental utilities. +;; Anything in this file can change or disappear. +;; +;; Copyright (C) 2014 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;; TODO: Split this file up by function? +;; E.g., (gdb experimental ports), etc. + +(define-module (gdb experimental) + #:use-module (gdb) + #:use-module (gdb init)) + +;; These are defined in C. +(define-public with-gdb-output-to-port (@@ (gdb) %with-gdb-output-to-port)) +(define-public with-gdb-error-to-port (@@ (gdb) %with-gdb-error-to-port)) + +(define-public (with-gdb-output-to-string thunk) + "Calls THUNK and returns all GDB output as a string." + (call-with-output-string + (lambda (p) (with-gdb-output-to-port p thunk)))) diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm new file mode 100644 index 0000000..12ad67d --- /dev/null +++ b/gdb/guile/lib/gdb/init.scm @@ -0,0 +1,173 @@ +;; Scheme side of the gdb module. +;; +;; Copyright (C) 2014 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gdb init) + #:use-module (gdb)) + +(define-public SCM_ARG1 1) +(define-public SCM_ARG2 2) + +;; The original i/o ports. In case the user wants them back. +(define %orig-input-port #f) +(define %orig-output-port #f) +(define %orig-error-port #f) + +;; %exception-print-style is exported as "private" by gdb. +(define %exception-print-style (@@ (gdb) %exception-print-style)) + +;; Keys for GDB-generated exceptions. +;; gdb:with-stack is handled separately. + +(define %exception-keys '(gdb:error + gdb:invalid-object-error + gdb:memory-error + gdb:pp-type-error)) + +;; Printer for gdb exceptions, used when Scheme tries to print them directly. + +(define (%exception-printer port key args default-printer) + (apply (case-lambda + ((subr msg args . rest) + (if subr + (format port "In procedure ~a: " subr)) + (apply format port msg (or args '()))) + (_ (default-printer))) + args)) + +;; Print the message part of a gdb:with-stack exception. +;; The arg list is the way it is because it's passed to set-exception-printer!. +;; We don't print a backtrace here because Guile will have already printed a +;; backtrace. + +(define (%with-stack-exception-printer port key args default-printer) + (let ((real-key (car args)) + (real-args (cddr args))) + (%exception-printer port real-key real-args default-printer))) + +;; Copy of Guile's print-exception that tweaks the output for our purposes. +;; TODO: It's not clear the tweaking is still necessary. + +(define (%print-exception-message-worker port key args) + (define (default-printer) + (format port "Throw to key `~a' with args `~s'." key args)) + (format port "ERROR: ") + ;; Pass #t for tag to catch all errors. + (catch #t + (lambda () + (%exception-printer port key args default-printer)) + (lambda (k . args) + (format port "Error while printing gdb exception: ~a ~s." + k args))) + (newline port) + (force-output port)) + +;; Called from the C code to print an exception. +;; Guile prints them a little differently than we want. +;; See boot-9.scm:print-exception. + +(define (%print-exception-message port frame key args) + (cond ((memq key %exception-keys) + (%print-exception-message-worker port key args)) + (else + (print-exception port frame key args))) + *unspecified*) + +;; Called from the C code to print an exception according to the setting +;; of "guile print-stack". +;; +;; If PORT is #f, use the standard error port. +;; If STACK is #f, never print the stack, regardless of whether printing it +;; is enabled. If STACK is #t, then print it if it is contained in ARGS +;; (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling +;; scm_make_stack (which will be ignored in favor of the stack in ARGS if +;; KEY is gdb:with-stack). +;; KEY, ARGS are the standard arguments to scm_throw, et.al. + +(define (%print-exception-with-stack port stack key args) + (let ((style (%exception-print-style))) + (if (not (eq? style 'none)) + (let ((error-port (current-error-port)) + (frame #f)) + (if (not port) + (set! port error-port)) + (if (eq? port error-port) + (begin + (force-output (current-output-port)) + ;; In case the current output port is not gdb's output port. + (force-output (output-port)))) + + ;; If the exception is gdb:with-stack, unwrap it to get the stack and + ;; underlying exception. If the caller happens to pass in a stack, + ;; we ignore it and use the one in ARGS instead. + (if (eq? key 'gdb:with-stack) + (begin + (set! key (car args)) + (if stack + (set! stack (cadr args))) + (set! args (cddr args)))) + + ;; If caller wanted a stack and there isn't one, disable backtracing. + (if (eq? stack #t) + (set! stack #f)) + ;; At this point if stack is true, then it is assumed to be a stack. + (if stack + (set! frame (stack-ref stack 0))) + + (if (and (eq? style 'full) stack) + (begin + ;; This is derived from libguile/throw.c:handler_message. + ;; We include "Guile" in "Guile Backtrace" whereas the Guile + ;; version does not so that tests can know it's us printing + ;; the backtrace. Plus it could help beginners. + (display "Guile Backtrace:\n" port) + (display-backtrace stack port #f #f '()) + (newline port))) + + (%print-exception-message port frame key args))))) + +;; Internal utility to check the type of an argument, akin to SCM_ASSERT_TYPE. +;; It's public so other gdb modules can use it. + +(define-public (%assert-type test-result arg pos func-name) + (if (not test-result) + (scm-error 'wrong-type-arg func-name + "Wrong type argument in position ~a: ~s" + (list pos arg) (list arg)))) + +;; Internal utility called during startup to initialize the Scheme side of +;; GDB+Guile. + +(define (%initialize!) + (add-to-load-path (string-append (data-directory) + file-name-separator-string "guile")) + + (for-each (lambda (key) + (set-exception-printer! key %exception-printer)) + %exception-keys) + (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer) + + (set! %orig-input-port (set-current-input-port (input-port))) + (set! %orig-output-port (set-current-output-port (output-port))) + (set! %orig-error-port (set-current-error-port (error-port)))) + +;; Public routines. + +(define-public (orig-input-port) %orig-input-port) +(define-public (orig-output-port) %orig-output-port) +(define-public (orig-error-port) %orig-error-port) diff --git a/gdb/guile/lib/gdb/iterator.scm b/gdb/guile/lib/gdb/iterator.scm new file mode 100644 index 0000000..9cfbe85 --- /dev/null +++ b/gdb/guile/lib/gdb/iterator.scm @@ -0,0 +1,80 @@ +;; Iteration utilities. +;; Anything in this file can change or disappear. +;; +;; Copyright (C) 2014 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gdb iterator) + #:use-module (gdb)) + +(define-public (make-list-iterator l) + "Return a <gdb:iterator> object for a list." + (%assert-type (list? l) l SCM_ARG1 'make-list-iterator) + (let ((next! (lambda (iter) + (let ((l (iterator-progress iter))) + (if (eq? l '()) + (end-of-iteration) + (begin + (set-iterator-progress! iter (cdr l)) + (car l))))))) + (make-iterator l l next!))) + +(define-public (iterator->list iter) + "Return the elements of ITER as a list." + (let loop ((iter iter) + (result '())) + (let ((next (iterator-next! iter))) + (if (end-of-iteration? next) + (reverse! result) + (loop iter (cons next result)))))) + +(define-public (iterator-map proc iter) + "Return a list of PROC applied to each element." + (let loop ((proc proc) + (iter iter) + (result '())) + (let ((next (iterator-next! iter))) + (if (end-of-iteration? next) + (reverse! result) + (loop proc iter (cons (proc next) result)))))) + +(define-public (iterator-for-each proc iter) + "Apply PROC to each element. The result is unspecified." + (let ((next (iterator-next! iter))) + (if (not (end-of-iteration? next)) + (begin + (proc next) + (iterator-for-each proc iter))))) + +(define-public (iterator-filter pred iter) + "Return the elements that satify predicate PRED." + (let loop ((result '())) + (let ((next (iterator-next! iter))) + (cond ((end-of-iteration? next) (reverse! result)) + ((pred next) (loop (cons next result))) + (else (loop result)))))) + +(define-public (iterator-until pred iter) + "Run the iterator until the result of (pred element) is true. + + Returns: + The result of the first (pred element) call that returns true, + or #f if no element matches." + (let loop ((next (iterator-next! iter))) + (cond ((end-of-iteration? next) #f) + ((pred next) => identity) + (else (loop (iterator-next! iter)))))) diff --git a/gdb/guile/lib/gdb/printing.scm b/gdb/guile/lib/gdb/printing.scm new file mode 100644 index 0000000..36e3275 --- /dev/null +++ b/gdb/guile/lib/gdb/printing.scm @@ -0,0 +1,52 @@ +;; Additional pretty-printer support. +;; +;; Copyright (C) 2014 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gdb printing) + #:use-module ((gdb) #:select + (*pretty-printers* pretty-printer? objfile? + objfile-pretty-printers set-objfile-pretty-printers!)) + #:use-module (gdb init)) + +(define-public (prepend-pretty-printer! obj matcher) + "Add MATCHER to the beginning of the pretty-printer list for OBJ. +If OBJ is #f, add MATCHER to the global list." + (%assert-type (pretty-printer? matcher) matcher SCM_ARG1 + 'prepend-pretty-printer!) + (cond ((eq? obj #f) + (set! *pretty-printers* (cons matcher *pretty-printers*))) + ((objfile? obj) + (set-objfile-pretty-printers! obj + (cons matcher + (objfile-pretty-printers obj)))) + (else + (%assert-type #f obj SCM_ARG1 'prepend-pretty-printer!)))) + +(define-public (append-pretty-printer! obj matcher) + "Add MATCHER to the end of the pretty-printer list for OBJ. +If OBJ is #f, add MATCHER to the global list." + (%assert-type (pretty-printer? matcher) matcher SCM_ARG1 + 'append-pretty-printer!) + (cond ((eq? obj #f) + (set! *pretty-printers* (append! *pretty-printers* (list matcher)))) + ((objfile? obj) + (set-objfile-pretty-printers! obj + (append! (objfile-pretty-printers obj) + matcher))) + (else + (%assert-type #f obj SCM_ARG1 'append-pretty-printer!)))) diff --git a/gdb/guile/lib/gdb/types.scm b/gdb/guile/lib/gdb/types.scm new file mode 100644 index 0000000..31ea192 --- /dev/null +++ b/gdb/guile/lib/gdb/types.scm @@ -0,0 +1,78 @@ +;; Type utilities. +;; Copyright (C) 2010-2014 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gdb types) + #:use-module (gdb) + #:use-module (gdb init) + #:use-module (gdb iterator)) + +(define-public (type-has-field-deep? type field-name) + "Return #t if the type, including baseclasses, has the specified field. + + Arguments: + type: The type to examine. It must be a struct or union. + field-name: The name of the field to look up. + + Returns: + True if the field is present either in type_ or any baseclass. + + Raises: + wrong-type-arg: The type is not a struct or union." + + (define (search-class type) + (let ((find-in-baseclass (lambda (field) + (if (field-baseclass? field) + (search-class (field-type field)) + ;; Not a baseclass, search ends now. + ;; Return #:end to end search. + #:end)))) + (let ((search-baseclasses + (lambda (type) + (iterator-until find-in-baseclass + (make-field-iterator type))))) + (or (type-has-field? type field-name) + (not (eq? (search-baseclasses type) #:end)))))) + + (if (= (type-code type) TYPE_CODE_REF) + (set! type (type-target type))) + (set! type (type-strip-typedefs type)) + + (%assert-type (memq (type-code type) (list TYPE_CODE_STRUCT TYPE_CODE_UNION)) + type SCM_ARG1 'type-has-field-deep?) + + (search-class type)) + +(define-public (make-enum-hashtable enum-type) + "Return a hash table from a program's enum type. + + Elements in the hash table are fetched with hashq-ref. + + Arguments: + enum-type: The enum to compute the hash table for. + + Returns: + The hash table of the enum. + + Raises: + wrong-type-arg: The type is not an enum." + + (%assert-type (= (type-code enum-type) TYPE_CODE_ENUM) + enum-type SCM_ARG1 'make-enum-hashtable) + (let ((htab (make-hash-table))) + (for-each (lambda (enum) + (hash-set! htab (field-name enum) (field-enumval enum))) + (type-fields enum-type)) + htab)) |