Re: libguile/print.c fixes

[prj@po.cwru.edu (Paul Jarc)]

[-- Attachment #1: Type: text/plain, Size: 386 bytes --]

I wrote:
> My copyright paperwork for Guile is now done.  Rob, can you install my
> setgroups and symbol-printing patches?

In case someone else is less busy... top-level ChangeLog:
	* configure.in: check for setgroups.
libguile/ChangeLog:
	* posix.c (scm_setgroups): new function.
	* print.c (scm_print_symbol_name): add comments and fix bugs
	for #{1}#, #{'x}#, and #{}\#\ }#.


paul

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: setgroups.patch --]
[-- Type: text/x-patch, Size: 2202 bytes --]

Index: configure.in
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/configure.in,v
retrieving revision 1.222
diff -u -r1.222 configure.in
--- configure.in	21 Jun 2003 00:15:09 -0000	1.222
+++ configure.in	30 Jun 2003 22:32:37 -0000
@@ -591,7 +591,7 @@
     [Define if the system supports Unix-domain (file-domain) sockets.])
 fi
 
-AC_CHECK_FUNCS(socketpair getgroups setpwent pause tzset)
+AC_CHECK_FUNCS(socketpair getgroups setgroups setpwent pause tzset)
 
 AC_CHECK_FUNCS(sethostent   gethostent   endhostent   dnl
                setnetent    getnetent    endnetent    dnl
Index: libguile/posix.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/posix.c,v
retrieving revision 1.118
diff -u -r1.118 posix.c
--- libguile/posix.c	14 Jun 2003 05:36:02 -0000	1.118
+++ libguile/posix.c	30 Jun 2003 22:32:38 -0000
@@ -228,6 +228,46 @@
 #undef FUNC_NAME  
 #endif
 
+#ifdef HAVE_SETGROUPS
+SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0,
+            (SCM group_vec),
+	    "Set the supplementary group IDs to those found in the vector argument.")
+#define FUNC_NAME s_scm_setgroups
+{
+  size_t ngroups;
+  size_t size;
+  size_t i;
+  int result;
+  int save_errno;
+  GETGROUPS_T *groups;
+
+  SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec);
+
+  ngroups = SCM_VECTOR_LENGTH (group_vec);
+
+  /* validate before allocating, so we don't have to worry about leaks */
+  for (i = 0; i < ngroups; i++)
+    SCM_VALIDATE_INUM (0, SCM_VECTOR_REF (group_vec, i));
+
+  size = ngroups * sizeof (GETGROUPS_T);
+  /* XXX - if (size / sizeof (GETGROUPS_T) != ngroups) out-of-range */
+  groups = scm_malloc (size);
+  if (groups == NULL)
+    SCM_MEMORY_ERROR;
+  for(i = 0; i < ngroups; i++)
+    groups [i] = SCM_INUM (SCM_VECTOR_REF (group_vec, i));
+
+  result = setgroups (ngroups, groups);
+  save_errno = errno; /* don't let free() touch errno */
+  free (groups);
+  errno = save_errno;
+  if (result < 0)
+    SCM_SYSERROR;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
 #ifdef HAVE_GETPWENT
 SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
             (SCM user),

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: print_symbol.patch --]
[-- Type: text/x-patch, Size: 3033 bytes --]

Index: libguile/print.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/print.c,v
retrieving revision 1.150
diff -u -r1.150 print.c
--- libguile/print.c	12 May 2003 20:46:52 -0000	1.150
+++ libguile/print.c	30 Jun 2003 22:32:38 -0000
@@ -300,27 +300,34 @@
 void
 scm_print_symbol_name (const char *str, size_t len, SCM port)
 {
-  size_t pos;
+  /* This points to the first character that has not yet been written to the
+   * port. */
+  size_t pos = 0;
+  /* This points to the character we're currently looking at. */
   size_t end;
-  int weird;
-  int maybe_weird;
+  /* If the name contains weird characters, we'll escape them with
+   * backslashes and set this flag; it indicates that we should surround the
+   * name with "#{" and "}#". */
+  int weird = 0;
+  /* Backslashes are not sufficient to make a name weird, but if a name is
+   * weird because of other characters, backslahes need to be escaped too.
+   * The first time we see a backslash, we set maybe_weird, and mw_pos points
+   * to the backslash.  Then if the name turns out to be weird, we re-process
+   * everything starting from mw_pos. */
+  int maybe_weird = 0;
   size_t mw_pos = 0;
-  
-  pos = 0;
-  weird = 0;
-  maybe_weird = 0;
-  
-  /* XXX - Lots of weird symbol names are missed, such as "12" or
-     "'a". */
+  /* If the name is purely numeric, then it's weird as a whole, even though
+   * none of the individual characters is weird.  But we won't know this
+   * until we reach the end of the name.  This flag describes the part of the
+   * name we've looked at so far. */
+  int all_digits = 1;
 
-  if (len == 0)
-    scm_lfwrite ("#{}#", 4, port);
-  else if (str[0] == '#' || str[0] == ':' || str[len-1] == ':')
+  if (len == 0 || str[0] == '\'' || str[0] == ':' || str[len-1] == ':')
     {
       scm_lfwrite ("#{", 2, port);
       weird = 1;
     }
-  
+
   for (end = pos; end < len; ++end)
     switch (str[end])
       {
@@ -332,8 +339,10 @@
       case ')':
       case '"':
       case ';':
+      case '#':
       case SCM_WHITE_SPACES:
       case SCM_LINE_INCREMENTORS:
+	all_digits = 0;
       weird_handler:
 	if (maybe_weird)
 	  {
@@ -346,9 +355,7 @@
 	    weird = 1;
 	  }
 	if (pos < end)
-	  {
-	    scm_lfwrite (str + pos, end - pos, port);
-	  }
+	  scm_lfwrite (str + pos, end - pos, port);
 	{
 	  char buf[2];
 	  buf[0] = '\\';
@@ -358,6 +365,7 @@
 	pos = end + 1;
 	break;
       case '\\':
+	all_digits = 0;
 	if (weird)
 	  goto weird_handler;
 	if (!maybe_weird)
@@ -366,14 +374,18 @@
 	    mw_pos = pos;
 	  }
 	break;
-      case '}':
-      case '#':
-	if (weird)
-	  goto weird_handler;
+      case '0': case '1': case '2': case '3': case '4':
+      case '5': case '6': case '7': case '8': case '9':
 	break;
       default:
+	all_digits = 0;
 	break;
       }
+  if (all_digits)
+    {
+      scm_lfwrite ("#{", 2, port);
+      weird = 1;
+    }
   if (pos < end)
     scm_lfwrite (str + pos, end - pos, port);
   if (weird)

[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel