* options.c (protected_objects, scm_init_options): The content of

protected_objects is now protected from garbage collection using
scm_gc_register_root instead of scm_permanent_object.

(get_option_setting):  New static function that	computes an option
setting as it was formerly done in the function scm_options.

(get_documented_option_setting):  New static function that
returns option documentation as it was formerly done in the
function scm_options.  Note that documentation C strings are no
longer precomputed into SCM objects.  Instead, they are converted
into SCM strings every time get_documented_option_setting is
called.

(change_option_setting):  New static functions that modifies the
option setting as it was formerly done in the function
scm_options.  The function is now exception safe, i. e. won't
cause a memory leak when interrupted.  Further, only non-immediate
option values are added to the protection list.

(scm_options):  This function now has only the purpose to dispatch
to to get_option_setting, get_documented_option_setting or
change_option_setting, depending on the arguments given to
scm_options.

(scm_init_opts):  Don't convert documentation C strings into SCM
strings.  Further, don't protect any object values:  They _must_
be immediate values, otherwise there is no guarantee that they
have not been collected before anyway.

* options.[ch] (scm_t_option):  Made type unsigned, name into a
constant char* and val into a scm_t_bits type.

(scm_options, scm_init_opts):  The number of options is guaranteed
to be larger or equal to zero.  Thus, the type is changed to
unsigned.

libguile/ChangeLog

@@ -1,3 +1,42 @@
+2001-10-05  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* options.c (protected_objects, scm_init_options):  The content of
+	protected_objects is now protected from garbage collection using
+	scm_gc_register_root instead of scm_permanent_object.
+
+	(get_option_setting):  New static function that	computes an option
+	setting as it was formerly done in the function scm_options.
+
+	(get_documented_option_setting):  New static function that
+	returns option documentation as it was formerly done in the
+	function scm_options.  Note that documentation C strings are no
+	longer precomputed into SCM objects.  Instead, they are converted
+	into SCM strings every time get_documented_option_setting is
+	called.
+
+	(change_option_setting):  New static functions that modifies the
+	option setting as it was formerly done in the function
+	scm_options.  The function is now exception safe, i. e. won't
+	cause a memory leak when interrupted.  Further, only non-immediate
+	option values are added to the protection list.
+
+	(scm_options):  This function now has only the purpose to dispatch
+	to to get_option_setting, get_documented_option_setting or
+	change_option_setting, depending on the arguments given to
+	scm_options.
+
+	(scm_init_opts):  Don't convert documentation C strings into SCM
+	strings.  Further, don't protect any object values:  They _must_
+	be immediate values, otherwise there is no guarantee that they
+	have not been collected before anyway.
+
+	* options.[ch] (scm_t_option):  Made type unsigned, name into a
+	constant char* and val into a scm_t_bits type.
+
+	(scm_options, scm_init_opts):  The number of options is guaranteed
+	to be larger or equal to zero.  Thus, the type is changed to
+	unsigned.
+
 2001-10-05  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* num2integral.i.c (NUM2INTEGRAL):  Eliminated some warnings about

libguile/options.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995, 1996, 1998, 2000, 2001 Free Software Foundation
+/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation
  * 
  * 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
@@ -42,10 +42,10 @@
  * The author can be reached at djurfeldt@nada.kth.se
  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
 
-
 
 
 #include "libguile/_scm.h"
+#include "libguile/mallocs.h"
 #include "libguile/strings.h"
 
 #include "libguile/options.h"
@@ -116,118 +116,173 @@
 SCM_SYMBOL (scm_yes_sym, "yes");
 SCM_SYMBOL (scm_no_sym, "no");
 
-static SCM protected_objects;
+static SCM protected_objects = SCM_EOL;
 
-SCM
+
-scm_options (SCM arg, scm_t_option options[], int n, const char *s)
+/* Return a list of the current option setting.  The format of an option
+ * setting is described in the above documentation.  */
+static SCM
+get_option_setting (const scm_t_option options[], unsigned int n)
 {
-  int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg));
+  unsigned int i;
-  /* Let `arg' GC protect the arguments */
+  SCM ls = SCM_EOL;
-  SCM new_mode = arg, ans = SCM_EOL, ls;
+  for (i = 0; i != n; ++i)
-  for (i = 0; i < n; ++i)
     {
-      ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans;
       switch (options[i].type)
 	{
 	case SCM_OPTION_BOOLEAN:
-	  if (docp)
+	  if (options[i].val)
-	    ls = scm_cons ((int) options[i].val
+	    ls = scm_cons (SCM_PACK (options[i].name), ls);
-			   ? scm_yes_sym
+	  break;
-			   : scm_no_sym,
+	case SCM_OPTION_INTEGER:
-			   ls);
+	  ls = scm_cons (SCM_MAKINUM (options[i].val), ls);
+	  ls = scm_cons (SCM_PACK (options[i].name), ls);
+	  break;
+	case SCM_OPTION_SCM:
+	  ls = scm_cons (SCM_PACK (options[i].val), ls);
+	  ls = scm_cons (SCM_PACK (options[i].name), ls);
+	}
+    }
+  return ls;
+}
+
+
+/* Return a list of sublists, where each sublist contains option name, value
+ * and documentation string.  */
+static SCM
+get_documented_option_setting (const scm_t_option options[], unsigned int n)
+{
+  SCM ans = SCM_EOL;
+  unsigned int i;
+
+  for (i = 0; i != n; ++i)
+    {
+      SCM ls = scm_cons (scm_str2string (options[i].doc), SCM_EOL);
+      switch (options[i].type)
+	{
+	case SCM_OPTION_BOOLEAN:
+	  ls = scm_cons (options[i].val ? scm_yes_sym : scm_no_sym, ls);
 	  break;
 	case SCM_OPTION_INTEGER:
 	  ls = scm_cons (SCM_MAKINUM (options[i].val), ls);
 	  break;
 	case SCM_OPTION_SCM:
-	  ls = scm_cons ((SCM) options[i].val, ls);
+	  ls = scm_cons (SCM_PACK (options[i].val), ls);
 	}
-      if (!((options[i].type == SCM_OPTION_BOOLEAN)
+      ls = scm_cons (SCM_PACK (options[i].name), ls);
-	    && !docp
+      ans = scm_cons (ls, ans);
-	    && ! (int) options[i].val))
-	ls = scm_cons ((SCM) options[i].name, ls);
-      ans = docp ? scm_cons (ls, ans) : ls;
-    }
-  if (!(SCM_UNBNDP (new_mode) || docp))
-    {
-      unsigned long *flags;
-      flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long),
-						 "mode buffer");
-      for (i = 0; i < n; ++i)
-	if (options[i].type == SCM_OPTION_BOOLEAN)
-	  flags[i] = 0;
-	else
-	  flags[i] = (unsigned long) options[i].val;
-      while (SCM_NNULLP (new_mode))
-	{
-	  SCM_ASSERT (SCM_CONSP (new_mode),
-		      new_mode,
-		      SCM_ARG1,
-		      s);
-	  for (i = 0; i < n; ++i)
-	    if (SCM_CAR (new_mode) == (SCM) options[i].name)
-	      switch (options[i].type)
-		{
-		case SCM_OPTION_BOOLEAN:
-		  flags[i] = 1;
-		  goto cont;
-		case SCM_OPTION_INTEGER:
-		  new_mode = SCM_CDR (new_mode);
-		  SCM_ASSERT (   SCM_CONSP (new_mode)
-			      && SCM_INUMP (SCM_CAR (new_mode)),
-			      new_mode,
-			      SCM_ARG1,
-			      s);
-		  flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode));
-		  goto cont;
-		case SCM_OPTION_SCM:
-		  new_mode = SCM_CDR (new_mode);
-		  flags[i] = SCM_UNPACK (SCM_CAR (new_mode));
-		  goto cont;
-		}
-#ifndef SCM_RECKLESS
-	  scm_must_free ((char *) flags);
-	  scm_misc_error (s, "Unknown mode flag: ~S", 
-			  scm_list_1 (SCM_CAR (new_mode)));
-#endif
-	cont:
-	  new_mode = SCM_CDR (new_mode);
-	}
-      for (i = 0; i < n; ++i)
-	{
-	  /* scm_option doesn't know if its a long or an SCM */
-	  if (options[i].type == SCM_OPTION_SCM)
-	    SCM_SETCDR (protected_objects,
-			scm_cons (SCM_PACK(flags[i]),
-				  scm_delq1_x (SCM_PACK(options[i].val),
-					       SCM_CDR (protected_objects))));
-	  options[i].val = flags[i];
-	}
-      scm_must_free ((char *) flags);
     }
   return ans;
 }
 
 
-void
+/* Alters options according to the given option setting 'args'.  The value of
-scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n)
+ * args is known to be a list, but it is not known whether the list is a well
+ * formed option setting, i. e. if for every non-boolean option a value is
+ * given.  For this reason, the function applies all changes to a copy of the
+ * original setting in memory.  Only if 'args' was successfully processed,
+ * the new setting will overwrite the old one.  */
+static void
+change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s)
 {
-  int i;
+  unsigned int i;
+  SCM locally_protected_args = args;
+  SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits));
+  scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
 
-  for (i = 0; i < n; ++i)
+  for (i = 0; i != n; ++i)
     {
-      SCM name;
+      if (options[i].type == SCM_OPTION_BOOLEAN)
-      SCM doc;
+	flags[i] = 0;
+      else
+	flags[i] = options[i].val;
+    }
 
-      name = scm_str2symbol (options[i].name);
+  while (!SCM_NULLP (args))
-      options[i].name =	(char *) name;
+    {
-      scm_permanent_object (name);
+      SCM name = SCM_CAR (args);
-      doc = scm_take0str (options[i].doc);
+      int found = 0;
-      options[i].doc = (char *) doc;
+
-      scm_permanent_object (doc);
+      for (i = 0; i != n && !found; ++i)
+	{
+	  if (SCM_EQ_P (name, SCM_PACK (options[i].name)))
+	    {
+	      switch (options[i].type)
+		{
+		case SCM_OPTION_BOOLEAN:
+		  flags[i] = 1;
+		  break;
+		case SCM_OPTION_INTEGER:
+		  args = SCM_CDR (args);
+		  SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG1, s);
+		  SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG1, s);
+		  flags[i] = SCM_INUM (SCM_CAR (args));
+		  break;
+		case SCM_OPTION_SCM:
+		  args = SCM_CDR (args);
+		  SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG1, s);
+		  flags[i] = SCM_UNPACK (SCM_CAR (args));
+		  break;
+		}
+	      found = 1;
+	    }
+	}
+
+      if (!found)
+	scm_misc_error (s, "Unknown option name: ~S", scm_list_1 (name));
+
+      args = SCM_CDR (args);
+    }
+
+  for (i = 0; i != n; ++i)
+    {
       if (options[i].type == SCM_OPTION_SCM)
-	SCM_SETCDR (protected_objects,
+	{
-		    scm_cons (SCM_PACK(options[i].val), SCM_CDR (protected_objects)));
+	  SCM old = SCM_PACK (options[i].val);
+	  SCM new = SCM_PACK (flags[i]);
+	  if (!SCM_IMP (old))
+	    protected_objects = scm_delq1_x (old, protected_objects);
+	  if (!SCM_IMP (new))
+	    protected_objects = scm_cons (new, protected_objects);
+	}
+      options[i].val = flags[i];
+    }
+
+  scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
+}
+
+
+SCM
+scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s)
+{
+  if (SCM_UNBNDP (args))
+    return get_option_setting (options, n);
+  else if (!SCM_NULLP (args) && !SCM_CONSP (args))
+    /* Dirk:FIXME:: This criterion should be improved.  IMO it is better to
+     * demand that args is #t if documentation should be shown than to say
+     * that every argument except a list will print out documentation.  */
+    return get_documented_option_setting (options, n);
+  else
+    {
+      SCM old_setting;
+      SCM_ASSERT (!SCM_FALSEP (scm_list_p (args)), args, 1, s);
+      old_setting = get_option_setting (options, n);
+      change_option_setting (args, options, n, s);
+      return old_setting;
+    }
+}
+
+
+void
+scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n)
+{
+  unsigned int i;
+
+  for (i = 0; i != n; ++i)
+    {
+      SCM name = scm_str2symbol (options[i].name);
+      options[i].name =	(char *) SCM_UNPACK (name);
+      scm_permanent_object (name);
     }
   func (SCM_UNDEFINED);
 }
@@ -236,7 +291,8 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n)
 void
 scm_init_options ()
 {
-  protected_objects = scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL));
+  scm_gc_register_root (&protected_objects);
+
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/options.x"
 #endif

libguile/options.h

@@ -55,14 +55,9 @@
 
 typedef struct scm_t_option
 {
-  int type;
+  unsigned int type;
-  char *name;
+  const char *name;
-
+  scm_t_bits val;
-  /*
-    schizophrenic use: both SCM and int
-   */
-  unsigned long val;
-  /* SCM val */
   char *doc;
 } scm_t_option;
 
@@ -72,8 +67,8 @@ typedef struct scm_t_option
 #define SCM_OPTION_SCM     2
 
 
-extern SCM scm_options (SCM new_mode, scm_t_option options[], int n, const char *s);
+extern SCM scm_options (SCM, scm_t_option [], unsigned int, const char*);
-extern void scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n);
+extern void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n);
 extern void scm_init_options (void);
 
 #endif  /* SCM_OPTIONS_H */