1 files changed, 375 insertions, 0 deletions
diff --git a/gdb/guile/scm-iterator.c b/gdb/guile/scm-iterator.c
new file mode 100644
index 0000000..a6deb84
--- /dev/null
+++ b/gdb/guile/scm-iterator.c
@@ -0,0 +1,375 @@
+/* Simple iterators for GDB/Scheme.
+
+   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/>.  */
+
+/* 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;
+
+/* A unique-enough marker to denote "end of iteration".  */
+static SCM end_of_iteration;
+
+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 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));
+}
+
+/* (end-of-iteration) -> an "end-of-iteration" marker
+   We rely on this not being used as a data result of an iterator.  */
+
+SCM
+gdbscm_end_of_iteration (void)
+{
+  return end_of_iteration;
+}
+
+/* Return non-zero if OBJ is the end-of-iteration marker.  */
+
+int
+itscm_is_end_of_iteration (SCM obj)
+{
+  return scm_is_eq (obj, end_of_iteration);
+}
+
+/* (end-of-iteration? obj) -> boolean */
+
+static SCM
+gdbscm_end_of_iteration_p (SCM obj)
+{
+  return scm_from_bool (itscm_is_end_of_iteration (obj));
+}
+
+/* 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.  */
+
+SCM
+itscm_get_iterator_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM_ASSERT_TYPE (itscm_is_iterator (self), self, arg_pos, func_name,
+		   iterator_smob_name);
+
+  return self;
+}
+
+/* (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.\n\
+      By convention end-of-iteration should be marked with (end-of-iteration)\n\
+      from module (gdb iterator)." },
+
+  { "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-of-iteration", 0, 0, 0, gdbscm_end_of_iteration,
+    "\
+Return the end-of-iteration marker." },
+
+  { "end-of-iteration?", 1, 0, 0, gdbscm_end_of_iteration_p,
+    "\
+Return #t if the object is the end-of-iteration marker." },
+
+  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);
+
+  /* We can make this more unique if it's necessary,
+     but this is good enough for now.  */
+  end_of_iteration = scm_from_latin1_keyword ("end-of-iteration");
+}