old-cross-binutils/gdb/guile/scm-iterator.c

/* Simple iterators for GDB/Scheme.

   Copyright (C) 2014-2016 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 "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, as_a_scm_t_subr (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, as_a_scm_t_subr (gdbscm_iterator_p),
    "\
Return #t if the object is a <gdb:iterator> object." },

  { "iterator-object", 1, 0, 0, as_a_scm_t_subr (gdbscm_iterator_object),
    "\
Return the object being iterated over." },

  { "iterator-progress", 1, 0, 0, as_a_scm_t_subr (gdbscm_iterator_progress),
    "\
Return the progress object of the iterator." },

  { "set-iterator-progress!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_iterator_progress_x),
    "\
Set the progress object of the iterator." },

  { "iterator-next!", 1, 0, 0, as_a_scm_t_subr (gdbscm_iterator_next_x),
    "\
Invoke the next! procedure of the iterator and return its result." },

  { "end-of-iteration", 0, 0, 0, as_a_scm_t_subr (gdbscm_end_of_iteration),
    "\
Return the end-of-iteration marker." },

  { "end-of-iteration?", 1, 0, 0, as_a_scm_t_subr (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_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");
}