This is the mail archive of the gdb-patches@sourceware.org mailing list for the GDB project.

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH v1 31/36] Guile extension language: Scheme files

This patch adds the Scheme files.

2013-12-24  Doug Evans  <xdje42@gmail.com>

	* 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.
	* 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/printing.scm: New file.
	* guile/lib/gdb/types.scm: New file.

	testsuite/
	* gdb.guile/types-module.cc: New file.
	* gdb.guile/types-module.exp: New file.

diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in
index 1e00c58..c23cb82 100644
--- a/gdb/data-directory/Makefile.in
+++ b/gdb/data-directory/Makefile.in
@@ -19,8 +19,9 @@
 srcdir = @srcdir@
 SYSCALLS_SRCDIR = $(srcdir)/../syscalls
 PYTHON_SRCDIR = $(srcdir)/../python/lib
+GUILE_SRCDIR = $(srcdir)/../guile/lib
 SYSTEM_GDBINIT_SRCDIR = $(srcdir)/../system-gdbinit
-VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR)
+VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(GUILE_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR)
 
 top_srcdir = @top_srcdir@
 top_builddir = @top_builddir@
@@ -71,6 +72,16 @@ PYTHON_FILES = \
 	gdb/function/__init__.py \
 	gdb/function/strfns.py
 
+GUILE_DIR = guile
+GUILE_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(GUILE_DIR)
+GUILE_FILES = \
+	./gdb.scm \
+	gdb/boot.scm \
+	gdb/experimental.scm \
+	gdb/init.scm \
+	gdb/printing.scm \
+	gdb/types.scm
+
 SYSTEM_GDBINIT_DIR = system-gdbinit
 SYSTEM_GDBINIT_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(SYSTEM_GDBINIT_DIR)
 SYSTEM_GDBINIT_FILES = \
@@ -110,7 +121,7 @@ FLAGS_TO_PASS = \
 	"RUNTESTFLAGS=$(RUNTESTFLAGS)"
 
 .PHONY: all
-all: stamp-syscalls stamp-python stamp-system-gdbinit
+all: stamp-syscalls stamp-python stamp-guile stamp-system-gdbinit
 
 # For portability's sake, we need to handle systems that don't have
 # symbolic links.
@@ -194,6 +205,43 @@ uninstall-python:
 	  done \
 	done
 
+stamp-guile: Makefile $(GUILE_FILES)
+	rm -rf ./$(GUILE_DIR)
+	files='$(GUILE_FILES)' ; \
+	for file in $$files ; do \
+	  dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
+	  $(INSTALL_DIR) ./$(GUILE_DIR)/$$dir ; \
+	  $(INSTALL_DATA) $(GUILE_SRCDIR)/$$file ./$(GUILE_DIR)/$$dir ; \
+	done
+	touch $@
+
+.PHONY: clean-guile
+clean-guile:
+	rm -rf $(GUILE_DIR)
+	rm -f stamp-guile
+
+.PHONY: install-guile
+install-guile:
+	files='$(GUILE_FILES)' ; \
+	for file in $$files ; do \
+	  dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
+	  $(INSTALL_DIR) $(GUILE_INSTALL_DIR)/$$dir ; \
+	  $(INSTALL_DATA) ./$(GUILE_DIR)/$$file $(GUILE_INSTALL_DIR)/$$dir ; \
+	done
+
+.PHONY: uninstall-guile
+uninstall-guile:
+	files='$(GUILE_FILES)' ; \
+	for file in $$files ; do \
+	  slashdir=`echo "/$$file" | sed 's,/[^/]*$$,,'` ; \
+	  rm -f $(GUILE_INSTALL_DIR)/$$file ; \
+	  while test "x$$file" != "x$$slashdir" ; do \
+	    rmdir 2>/dev/null "$(GUILE_INSTALL_DIR)$$slashdir" ; \
+	    file="$$slashdir" ; \
+	    slashdir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
+	  done \
+	done
+
 stamp-system-gdbinit: Makefile $(SYSTEM_GDBINIT_FILES)
 	rm -rf ./$(SYSTEM_GDBINIT_DIR)
 	mkdir ./$(SYSTEM_GDBINIT_DIR)
@@ -245,13 +293,15 @@ install: all
 	@$(MAKE) $(FLAGS_TO_PASS) install-only
 
 .PHONY: install-only
-install-only: install-syscalls install-python install-system-gdbinit
+install-only: install-syscalls install-python install-guile \
+	install-system-gdbinit
 
 .PHONY: uninstall
-uninstall: uninstall-syscalls uninstall-python uninstall-system-gdbinit
+uninstall: uninstall-syscalls uninstall-python uninstall-guile \
+	uninstall-system-gdbinit
 
 .PHONY: clean
-clean: clean-syscalls clean-python clean-system-gdbinit
+clean: clean-syscalls clean-python clean-guile clean-system-gdbinit
 
 .PHONY: maintainer-clean realclean distclean
 maintainer-clean realclean distclean: clean
diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm
new file mode 100644
index 0000000..cf87138
--- /dev/null
+++ b/gdb/guile/lib/gdb.scm
@@ -0,0 +1,447 @@
+;; Scheme side of the gdb module.
+;;
+;; Copyright (C) 2013 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!
+
+ ;; 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
+ 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-aux
+ set-gsmob-aux!
+
+ ;; 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..6ea332a
--- /dev/null
+++ b/gdb/guile/lib/gdb/boot.scm
@@ -0,0 +1,31 @@
+;; Bootstrap the Scheme side of the gdb module.
+;;
+;; Copyright (C) 2013 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..4be582c
--- /dev/null
+++ b/gdb/guile/lib/gdb/experimental.scm
@@ -0,0 +1,110 @@
+;; Various experimental utilities.
+;; Anything in this file can change or disappear.
+;;
+;; Copyright (C) 2013 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))))
+
+(define-public (set-smob-converters! from-smob to-smob)
+  "Set the GDB smob converters, *smob->scm* and *scm->smob*.
+
+  It is not intended that different modules provide their own values.
+  These hooks exist to provide a way to build something on top of GDB smobs,
+  but this facility is experimental.
+
+  Arguments: from-smob to-smob
+    from-smob: a procedure of one argument, a GDB smob,
+      and returns a form of the smob used by the application
+    to-smob:   a procedure of one argument, a Scheme object returned
+      by from-smob, and returns the original GDB smob.
+
+  The result is unspecified."
+
+  (let ((func-name 'set-smob-converters!)
+	(pred (lambda (arg) (or (not arg) (procedure? arg)))))
+    (%assert-type (pred from-smob) from-smob SCM_ARG1 func-name)
+    (%assert-type (pred to-smob) to-smob SCM_ARG2 func-name))
+
+  (set! (@@ (gdb) *smob->scm*) from-smob)
+  (set! (@@ (gdb) *scm->smob*) to-smob)
+  (if #f #f))
+
+;; Iterators
+
+(define-public (make-list-iterator l end-marker)
+  "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-marker
+		       (begin
+			 (set-iterator-progress! iter (cdr l))
+			 (car l)))))))
+    (make-iterator l l next!)))
+
+(define-public (iterator-map proc iter end-marker)
+  "Return a list of PROC applied to each element."
+  (let loop ((proc proc)
+	     (iter iter)
+	     (result '()))
+    (let ((next (iterator-next! iter)))
+      (if (eq? next end-marker)
+	  (reverse! result)
+	  (loop proc iter (cons (proc next) result))))))
+
+(define-public (iterator-for-each proc iter end-marker)
+  "Apply PROC to each element.  The result is unspecified."
+  (let ((next (iterator-next! iter)))
+    (if (not (eq? next end-marker))
+	(begin
+	  (proc next)
+	  (iterator-for-each proc iter end-marker)))))
+
+(define-public (iterator-filter pred iter end-marker)
+  "Return the elements that satify predicate PRED."
+  (let loop ((result '()))
+    (let ((next (iterator-next! iter)))
+      (cond ((eq? next end-marker) (reverse! result))
+	    ((pred next) (loop (cons next result)))
+	    (else (loop result))))))
+
+(define-public (iterator-until pred iter end-marker)
+  "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 ((eq? next end-marker) #f)
+	  ((pred next) => identity)
+	  (else (loop (iterator-next! iter))))))
diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm
new file mode 100644
index 0000000..60289ed
--- /dev/null
+++ b/gdb/guile/lib/gdb/init.scm
@@ -0,0 +1,131 @@
+;; Scheme side of the gdb module.
+;;
+;; Copyright (C) 2013 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)
+
+;; 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 (%error-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 also passed to
+;; set-exception-printer!.
+;; We don't print a backtrace here because when invoked by Guile it will have
+;; already printed a backtrace.
+
+(define (%print-with-stack-exception-message port key args default-printer)
+  (let ((real-key (car args))
+	(real-args (cddr args)))
+    (%error-printer port real-key real-args default-printer)))
+
+;; Copy of Guile's print-exception that tweaks the output for our purposes.
+
+(define (%print-exception-worker port frame 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 ()
+	   (%error-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))
+
+;; Print a gdb:with-stack exception, including the backtrace.
+;; This is a special exception that wraps the real exception and includes
+;; the stack.  It is used to record the stack at the point of the exception,
+;; but defer printing it until now.
+
+(define (%print-with-stack-exception port key args)
+  (let ((real-key (car args))
+	(stack (cadr args))
+	(real-args (cddr args)))
+    (display "Backtrace:\n" port)
+    (display-backtrace stack port #f #f '())
+    (newline port)
+    (%print-exception port (stack-ref stack 0) real-key real-args)))
+
+;; 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 port frame key args)
+  (cond ((eq? key 'gdb:with-stack)
+	 (%print-with-stack-exception port key args))
+	((memq key %exception-keys)
+	 (%print-exception-worker port frame key args))
+	(else
+	 (print-exception 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 this 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 %error-printer))
+	    %exception-keys)
+  (set-exception-printer! 'gdb:with-stack %print-with-stack-exception-message)
+
+  (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/printing.scm b/gdb/guile/lib/gdb/printing.scm
new file mode 100644
index 0000000..6c0259a
--- /dev/null
+++ b/gdb/guile/lib/gdb/printing.scm
@@ -0,0 +1,52 @@
+;; Additional pretty-printer support.
+;;
+;; Copyright (C) 2013 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..c7e7d13
--- /dev/null
+++ b/gdb/guile/lib/gdb/types.scm
@@ -0,0 +1,78 @@
+;; Type utilities.
+;; Copyright (C) 2010-2013 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 experimental))
+
+(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)
+						  #f))))
+	(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))
diff --git a/gdb/testsuite/gdb.guile/types-module.cc b/gdb/testsuite/gdb.guile/types-module.cc
new file mode 100644
index 0000000..40e3924
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/types-module.cc
@@ -0,0 +1,38 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+   Copyright 2013 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/>.  */
+
+enum enum_type { A, B, C };
+
+class base
+{
+ public:
+  int base_member;
+};
+
+class derived : public base
+{
+ public:
+  enum_type derived_member;
+};
+
+derived d;
+
+int
+main (void)
+{
+  return 0;
+}
diff --git a/gdb/testsuite/gdb.guile/types-module.exp b/gdb/testsuite/gdb.guile/types-module.exp
new file mode 100644
index 0000000..5da8b24
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/types-module.exp
@@ -0,0 +1,50 @@
+# Copyright (C) 2013 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/>.
+
+# This file is part of the GDB testsuite.
+# It tests the (gdb types) module.
+
+load_lib gdb-guile.exp
+
+standard_testfile .cc
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+    return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+    return
+}
+
+gdb_scm_test_silent_cmd "guile (use-modules (gdb types) (gdb experimental))" \
+    "import (gdb types) (gdb experimental)"
+
+gdb_scm_test_silent_cmd "guile (define d (lookup-type \"derived\"))" \
+    "get derived type"
+
+gdb_test "guile (print (type-has-field? d \"base_member\"))" \
+    "= #f" "type-has-field? member in baseclass"
+
+gdb_test "guile (print (type-has-field-deep? d \"base_member\"))" \
+    "= #t" "type-has-field-deep? member in baseclass"
+
+gdb_scm_test_silent_cmd "guile (define enum-htab (make-enum-hashtable (lookup-type \"enum_type\")))" \
+    "create enum hash table"
+
+gdb_test "guile (print (hash-ref enum-htab \"B\"))" \
+    "= 1" "verify make-enum-hashtable"
Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]