This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[PATCH v1 17/36] Guile extension language: scm-iterator.c
- From: Doug Evans <xdje42 at gmail dot com>
- To: gdb-patches at sourceware dot org
- Date: Tue, 24 Dec 2013 11:03:21 -0800
- Subject: [PATCH v1 17/36] Guile extension language: scm-iterator.c
- Authentication-results: sourceware.org; auth=none
This patch adds support for simple iterators.
They're explained in the file.
2013-12-24 Doug Evans <xdje42@gmail.com>
* guile/scm-iterator.c: New file.
testsuite/
* gdb.guile/scm-iterator.c: New file.
* gdb.guile/scm-iterator.exp: New file.
diff --git a/gdb/guile/scm-iterator.c b/gdb/guile/scm-iterator.c
new file mode 100644
index 0000000..7ba03b3
--- /dev/null
+++ b/gdb/guile/scm-iterator.c
@@ -0,0 +1,350 @@
+/* Simple iterators for GDB/Scheme.
+
+ 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/>. */
+
+/* See README file in this directory for implementation notes, coding
+ conventions, et.al. */
+
+/* These are *simple* iterators, used to implement iterating over a collection
+ of objects. They are implemented as a smob containing three objects:
+
+ 1) the object being iterated over,
+ 2) an object to record the progress of the iteration,
+ 3) a procedure of one argument (the iterator object) that returns the next
+ object in the iteration or a pre-determined end marker.
+
+ Simple example:
+
+ (define-public (make-list-iterator l end-marker)
+ "Return a <gdb:iterator> object for a list."
+ (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 l '(1 2))
+ (define i (make-list-iterator l #:eoi))
+ (iterator-next! i) -> 1
+ (iterator-next! i) -> 2
+ (iterator-next! i) -> #:eoi
+
+ There is SRFI 41, Streams. We might support that too eventually (not with
+ this interface of course). */
+
+#include "defs.h"
+#include "guile-internal.h"
+
+/* A smob for iterating over something.
+ Typically this is used when computing a list of everything is
+ too expensive.
+ The typedef for this struct is in guile-internal.h. */
+
+struct _iterator_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The object being iterated over. */
+ SCM object;
+
+ /* An arbitrary object describing the progress of the iteration.
+ This is used by next_x to track progress. */
+ SCM progress;
+
+ /* A procedure of one argument, the iterator.
+ It returns the next object in the iteration.
+ How to signal "end of iteration" is up to next_x. */
+ SCM next_x;
+};
+
+static const char iterator_smob_name[] = "gdb:iterator";
+
+/* The tag Guile knows the iterator smob by. */
+static scm_t_bits iterator_smob_tag;
+
+const char *
+itscm_iterator_smob_name (void)
+{
+ return iterator_smob_name;
+}
+
+SCM
+itscm_iterator_smob_object (iterator_smob *i_smob)
+{
+ return i_smob->object;
+}
+
+SCM
+itscm_iterator_smob_progress (iterator_smob *i_smob)
+{
+ return i_smob->progress;
+}
+
+void
+itscm_set_iterator_smob_progress_x (iterator_smob *i_smob, SCM progress)
+{
+ i_smob->progress = progress;
+}
+
+/* Administrivia for iterator smobs. */
+
+/* The smob "mark" function for <gdb:iterator>. */
+
+static SCM
+itscm_mark_iterator_smob (SCM self)
+{
+ iterator_smob *i_smob = (iterator_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (i_smob->object);
+ scm_gc_mark (i_smob->progress);
+ scm_gc_mark (i_smob->next_x);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&i_smob->base);
+}
+
+/* The smob "print" function for <gdb:iterator>. */
+
+static int
+itscm_print_iterator_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ iterator_smob *i_smob = (iterator_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", iterator_smob_name);
+ scm_write (i_smob->object, port);
+ scm_puts (" ", port);
+ scm_write (i_smob->progress, port);
+ scm_puts (" ", port);
+ scm_write (i_smob->next_x, port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to make a <gdb:iterator> object.
+ Caller must verify correctness of arguments.
+ No exceptions are thrown. */
+
+static SCM
+itscm_make_iterator_smob (SCM object, SCM progress, SCM next)
+{
+ iterator_smob *i_smob = (iterator_smob *)
+ scm_gc_malloc (sizeof (iterator_smob), iterator_smob_name);
+ SCM i_scm;
+
+ i_smob->object = object;
+ i_smob->progress = progress;
+ i_smob->next_x = next;
+ i_scm = scm_new_smob (iterator_smob_tag, (scm_t_bits) i_smob);
+ gdbscm_init_gsmob (&i_smob->base);
+
+ return i_scm;
+}
+
+/* (make-iterator object object procedure) -> <gdb:iterator> */
+
+SCM
+gdbscm_make_iterator (SCM object, SCM progress, SCM next)
+{
+ SCM i_scm;
+
+ SCM_ASSERT_TYPE (gdbscm_is_procedure (next), next, SCM_ARG3, FUNC_NAME,
+ _("procedure"));
+
+ i_scm = itscm_make_iterator_smob (object, progress, next);
+
+ return gdbscm_scm_from_gsmob_unsafe (i_scm);
+}
+
+/* Return non-zero if SCM is a <gdb:iterator> object. */
+
+int
+itscm_is_iterator (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (iterator_smob_tag, scm);
+}
+
+/* (iterator? object) -> boolean */
+
+static SCM
+gdbscm_iterator_p (SCM scm)
+{
+ return scm_from_bool (itscm_is_iterator (scm));
+}
+
+/* Returns the <gdb:iterator> object contained in SCM or #f if SCM is not a
+ <gdb:iterator> object.
+ Returns a <gdb:exception> object if there was a problem during the
+ conversion. */
+
+SCM
+itscm_scm_to_iterator_gsmob (SCM scm)
+{
+ return gdbscm_scm_to_gsmob_safe (scm, iterator_smob_tag);
+}
+
+/* Call the next! method on ITER, which must be a <gdb:iterator> object.
+ Returns a <gdb:exception> object if an exception is thrown.
+ OK_EXCPS is passed to gdbscm_safe_call_1. */
+
+SCM
+itscm_safe_call_next_x (SCM iter, excp_matcher_func *ok_excps)
+{
+ iterator_smob *i_smob;
+
+ gdb_assert (itscm_is_iterator (iter));
+
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (iter);
+ return gdbscm_safe_call_1 (i_smob->next_x, iter, ok_excps);
+}
+
+/* Iterator methods. */
+
+/* Returns the <gdb:iterator> smob in SELF.
+ Throws an exception if SELF is not an iterator smob
+ (after passing it through *scm->smob*). */
+
+SCM
+itscm_get_iterator_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM i_scm = itscm_scm_to_iterator_gsmob (self);
+
+ if (gdbscm_is_exception (i_scm))
+ gdbscm_throw (i_scm);
+
+ SCM_ASSERT_TYPE (itscm_is_iterator (i_scm), self, arg_pos, func_name,
+ iterator_smob_name);
+
+ return i_scm;
+}
+
+/* (iterator-object <gdb:iterator>) -> object */
+
+static SCM
+gdbscm_iterator_object (SCM self)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+
+ return i_smob->object;
+}
+
+/* (iterator-progress <gdb:iterator>) -> object */
+
+static SCM
+gdbscm_iterator_progress (SCM self)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+
+ return i_smob->progress;
+}
+
+/* (set-iterator-progress! <gdb:iterator> object) -> unspecified */
+
+static SCM
+gdbscm_set_iterator_progress_x (SCM self, SCM value)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+
+ i_smob->progress = value;
+ return SCM_UNSPECIFIED;
+}
+
+/* (iterator-next! <gdb:iterator>) -> object
+ The result is the next value in the iteration or some "end" marker.
+ It is up to each iterator's next! function to specify what its end
+ marker is. */
+
+static SCM
+gdbscm_iterator_next_x (SCM self)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+ /* We leave type-checking of the procedure to gdbscm_safe_call_1. */
+
+ return gdbscm_safe_call_1 (i_smob->next_x, self, NULL);
+}
+
+/* Initialize the Scheme iterator code. */
+
+static const scheme_function iterator_functions[] =
+{
+ { "make-iterator", 3, 0, 0, gdbscm_make_iterator,
+ "\
+Create a <gdb:iterator> object.\n\
+\n\
+ Arguments: object progress next!\n\
+ object: The object to iterate over.\n\
+ progress: An object to use to track progress of the iteration.\n\
+ next!: A procedure of one argument, the iterator.\n\
+ Returns the next element in the iteration or an implementation-chosen\n\
+ value to signify iteration is complete." },
+
+ { "iterator?", 1, 0, 0, gdbscm_iterator_p,
+ "\
+Return #t if the object is a <gdb:iterator> object." },
+
+ { "iterator-object", 1, 0, 0, gdbscm_iterator_object,
+ "\
+Return the object being iterated over." },
+
+ { "iterator-progress", 1, 0, 0, gdbscm_iterator_progress,
+ "\
+Return the progress object of the iterator." },
+
+ { "set-iterator-progress!", 2, 0, 0, gdbscm_set_iterator_progress_x,
+ "\
+Set the progress object of the iterator." },
+
+ { "iterator-next!", 1, 0, 0, gdbscm_iterator_next_x,
+ "\
+Invoke the next! procedure of the iterator and return its result." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_iterators (void)
+{
+ iterator_smob_tag = gdbscm_make_smob_type (iterator_smob_name,
+ sizeof (iterator_smob));
+ scm_set_smob_mark (iterator_smob_tag, itscm_mark_iterator_smob);
+ scm_set_smob_print (iterator_smob_tag, itscm_print_iterator_smob);
+
+ gdbscm_define_functions (iterator_functions, 1);
+}
diff --git a/gdb/testsuite/gdb.guile/scm-iterator.c b/gdb/testsuite/gdb.guile/scm-iterator.c
new file mode 100644
index 0000000..95035dc
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-iterator.c
@@ -0,0 +1,28 @@
+/* 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/>. */
+
+void
+foo (void)
+{
+}
+
+int
+main (void)
+{
+ foo ();
+ return 0; /* Break at end. */
+}
diff --git a/gdb/testsuite/gdb.guile/scm-iterator.exp b/gdb/testsuite/gdb.guile/scm-iterator.exp
new file mode 100644
index 0000000..f99f1cb
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-iterator.exp
@@ -0,0 +1,56 @@
+# 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 experimental iterator facility.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+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_breakpoint [gdb_get_line_number "Break at end."]
+gdb_continue_to_breakpoint "Break at end."
+
+gdb_scm_test_silent_cmd "guile (use-modules (gdb experimental))" \
+ "import (gdb experimental)"
+
+gdb_scm_test_silent_cmd "guile (define this-sal (find-pc-line (frame-pc (selected-frame))))" \
+ "get frame sal"
+
+gdb_scm_test_silent_cmd "guile (define this-symtab (sal-symtab this-sal))" \
+ "get frame symtab"
+
+gdb_scm_test_silent_cmd "guile (define this-global-block (symtab-global-block this-symtab))" \
+ "get frame global block"
+
+gdb_scm_test_silent_cmd "guile (define syms-iter (make-block-symbols-iterator this-global-block))" \
+ "get global block iterator"
+
+gdb_scm_test_silent_cmd "guile (define functions (iterator-filter symbol-function? syms-iter #f))" \
+ "get global functions"
+
+gdb_test "guile (print (sort (map symbol-name functions) string<?))" \
+ "= \\(foo main\\)" "test function list"