[gimp] R5RS compatability fix for string->number and number->string (SF bug #3399335) Optional radix parame

[Kevin Cozens <kcozens src gnome org>]

commit df30fd6e682bc0453806d934a8559c9ba1cc12bd
Author: Kevin Cozens <kcozens svn gnome org>
Date:   Fri Dec 14 17:36:26 2012 -0500

    R5RS compatability fix for string->number and number->string (SF bug #3399335)
    Optional radix parameter from SVN version 92 of official version of TinyScheme.

 plug-ins/script-fu/scripts/script-fu.init |    7 +-
 plug-ins/script-fu/tinyscheme/init.scm    |    7 +-
 plug-ins/script-fu/tinyscheme/opdefines.h |    4 +-
 plug-ins/script-fu/tinyscheme/scheme.c    |  120 ++++++++++++++++++++++-------
 4 files changed, 103 insertions(+), 35 deletions(-)
---
diff --git a/plug-ins/script-fu/scripts/script-fu.init b/plug-ins/script-fu/scripts/script-fu.init
index 120ecc7..ba96022 100644
--- a/plug-ins/script-fu/scripts/script-fu.init
+++ b/plug-ins/script-fu/scripts/script-fu.init
@@ -142,7 +142,9 @@
        (if (pred a) a
          (error "string->xxx: not a xxx" a))))
 
-(define (string->number str) (string->anyatom str number?))
+(define (string->number str . base)
+    (let ((n (string->atom str (if (null? base) 10 (car base)))))
+        (if (number? n) n #f)))
 
 (define (anyatom->string n pred)
   (if (pred n)
@@ -150,7 +152,8 @@
       (error "xxx->string: not a xxx" n)))
 
 
-(define (number->string n) (anyatom->string n number?))
+(define (number->string n . base)
+    (atom->string n (if (null? base) 10 (car base))))
 
 (define (char-cmp? cmp a b)
      (cmp (char->integer a) (char->integer b)))
diff --git a/plug-ins/script-fu/tinyscheme/init.scm b/plug-ins/script-fu/tinyscheme/init.scm
index 120ecc7..25896d3 100644
--- a/plug-ins/script-fu/tinyscheme/init.scm
+++ b/plug-ins/script-fu/tinyscheme/init.scm
@@ -142,15 +142,18 @@
        (if (pred a) a
          (error "string->xxx: not a xxx" a))))
 
-(define (string->number str) (string->anyatom str number?))
+(define (string->number str . base)
+    (let ((n (string->atom str (if (null? base) 10 (car base)))))
+        (if (number? n) n #f)))
 
 (define (anyatom->string n pred)
   (if (pred n)
       (atom->string n)
       (error "xxx->string: not a xxx" n)))
 
+(define (number->string n . base)
+    (atom->string n (if (null? base) 10 (car base))))
 
-(define (number->string n) (anyatom->string n number?))
 
 (define (char-cmp? cmp a b)
      (cmp (char->integer a) (char->integer b)))
diff --git a/plug-ins/script-fu/tinyscheme/opdefines.h b/plug-ins/script-fu/tinyscheme/opdefines.h
index 3101eef..ceb4d0e 100644
--- a/plug-ins/script-fu/tinyscheme/opdefines.h
+++ b/plug-ins/script-fu/tinyscheme/opdefines.h
@@ -88,9 +88,9 @@
     _OP_DEF(opexe_2, "char-upcase",                    1,  1,       TST_CHAR,                        OP_CHARUPCASE       )
     _OP_DEF(opexe_2, "char-downcase",                  1,  1,       TST_CHAR,                        OP_CHARDNCASE       )
     _OP_DEF(opexe_2, "symbol->string",                 1,  1,       TST_SYMBOL,                      OP_SYM2STR          )
-    _OP_DEF(opexe_2, "atom->string",                   1,  1,       TST_ANY,                         OP_ATOM2STR         )
+    _OP_DEF(opexe_2, "atom->string",                   1,  2,       TST_ANY TST_NATURAL,             OP_ATOM2STR         )
     _OP_DEF(opexe_2, "string->symbol",                 1,  1,       TST_STRING,                      OP_STR2SYM          )
-    _OP_DEF(opexe_2, "string->atom",                   1,  1,       TST_STRING,                      OP_STR2ATOM         )
+    _OP_DEF(opexe_2, "string->atom",                   1,  2,       TST_STRING TST_NATURAL,          OP_STR2ATOM         )
     _OP_DEF(opexe_2, "make-string",                    1,  2,       TST_NATURAL TST_CHAR,            OP_MKSTRING         )
     _OP_DEF(opexe_2, "string-length",                  1,  1,       TST_STRING,                      OP_STRLEN           )
     _OP_DEF(opexe_2, "string-ref",                     2,  2,       TST_STRING TST_NATURAL,          OP_STRREF           )
diff --git a/plug-ins/script-fu/tinyscheme/scheme.c b/plug-ins/script-fu/tinyscheme/scheme.c
index cbfdc1b..ad47dc2 100644
--- a/plug-ins/script-fu/tinyscheme/scheme.c
+++ b/plug-ins/script-fu/tinyscheme/scheme.c
@@ -1437,7 +1437,6 @@ static int file_push(scheme *sc, const char *fname) {
     if(fname)
       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
 #endif
-
   }
   return fin!=0;
 }
@@ -2126,17 +2125,38 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
           snprintf(p, STRBUFFSIZE, "#<PORT>");
      } else if (is_number(l)) {
           p = sc->strbuff;
-          if(num_is_integer(l)) {
-               snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
+          if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
+              if(num_is_integer(l)) {
+                   snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
+              } else {
+                   snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
+                   /* r5rs says there must be a '.' (unless 'e'?) */
+                   f = strcspn(p, ".e");
+                   if (p[f] == 0) {
+                        p[f] = '.'; // not found, so add '.0' at the end
+                        p[f+1] = '0';
+                        p[f+2] = 0;
+                   }
+              }
           } else {
-               snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
-               /* R5RS says there must be a '.' (unless 'e'?) */
-               f = strcspn(p, ".e");
-               if (p[f] == 0) {
-                    p[f] = '.'; // not found, so add '.0' at the end
-                    p[f+1] = '0';
-                    p[f+2] = 0;
-               }
+              long v = ivalue(l);
+              if (f == 16) {
+                  if (v >= 0)
+                    snprintf(p, STRBUFFSIZE, "%lx", v);
+                  else
+                    snprintf(p, STRBUFFSIZE, "-%lx", -v);
+              } else if (f == 8) {
+                  if (v >= 0)
+                    snprintf(p, STRBUFFSIZE, "%lo", v);
+                  else
+                    snprintf(p, STRBUFFSIZE, "-%lo", -v);
+              } else if (f == 2) {
+                  unsigned long b = (v < 0) ? -v : v;
+                  p = &p[STRBUFFSIZE-1];
+                  *p = 0;
+                  do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
+                  if (v < 0) *--p = '-';
+              }
           }
      } else if (is_string(l)) {
           if (!f) {
@@ -2981,7 +3001,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                sc->code = car(sc->code);
           else
                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
-                               * car(sc->NIL) = sc->NIL */
+                                            * car(sc->NIL) = sc->NIL */
           s_goto(sc,OP_EVAL);
 
      case OP_LET0:       /* let */
@@ -3528,28 +3548,70 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
 
      case OP_STR2ATOM: /* string->atom */ {
-       char *s=strvalue(car(sc->args));
-       if(*s=='#') {
-         s_return(sc, mk_sharp_const(sc, s+1));
-       } else {
-         s_return(sc, mk_atom(sc, s));
-       }
-     }
+          char *s=strvalue(car(sc->args));
+          long pf = 0;
+          if(cdr(sc->args)!=sc->NIL) {
+            /* we know cadr(sc->args) is a natural number */
+            /* see if it is 2, 8, 10, or 16, or error */
+            pf = ivalue_unchecked(cadr(sc->args));
+            if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
+               /* base is OK */
+            }
+            else {
+              pf = -1;
+            }
+          }
+          if (pf < 0) {
+            Error_1(sc, "string->atom: bad base:", cadr(sc->args));
+          } else if(*s=='#') /* no use of base! */ {
+            s_return(sc, mk_sharp_const(sc, s+1));
+          } else {
+            if (pf == 0 || pf == 10) {
+              s_return(sc, mk_atom(sc, s));
+            }
+            else {
+              char *ep;
+              long iv = strtol(s,&ep,(int )pf);
+              if (*ep == 0) {
+                s_return(sc, mk_integer(sc, iv));
+              }
+              else {
+                s_return(sc, sc->F);
+              }
+            }
+          }
+        }
 
      case OP_SYM2STR: /* symbol->string */
           x=mk_string(sc,symname(car(sc->args)));
           setimmutable(x);
           s_return(sc,x);
-     case OP_ATOM2STR: /* atom->string */
-       x=car(sc->args);
-       if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
-         char *p;
-         int len;
-         atom2str(sc,x,0,&p,&len);
-         s_return(sc,mk_counted_string(sc,p,len));
-       } else {
-         Error_1(sc, "atom->string: not an atom:", x);
-       }
+
+     case OP_ATOM2STR: /* atom->string */ {
+          long pf = 0;
+          x=car(sc->args);
+          if(cdr(sc->args)!=sc->NIL) {
+            /* we know cadr(sc->args) is a natural number */
+            /* see if it is 2, 8, 10, or 16, or error */
+            pf = ivalue_unchecked(cadr(sc->args));
+            if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
+              /* base is OK */
+            }
+            else {
+              pf = -1;
+            }
+          }
+          if (pf < 0) {
+            Error_1(sc, "atom->string: bad base:", cadr(sc->args));
+          } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
+            char *p;
+            int len;
+            atom2str(sc,x,(int )pf,&p,&len);
+            s_return(sc,mk_counted_string(sc,p,len));
+          } else {
+            Error_1(sc, "atom->string: not an atom:", x);
+          }
+        }
 
      case OP_MKSTRING: { /* make-string */
           gunichar fill=' ';