~ chicken-core (chicken-5) 14b2d48ca65a2e53af484ebd363a2c58b5dc8b0c
commit 14b2d48ca65a2e53af484ebd363a2c58b5dc8b0c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Apr 4 22:57:26 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Apr 4 22:57:26 2010 +0200
applied patch by Christian Kellermann for number->string conversion with arbitrary base
diff --git a/chicken.h b/chicken.h
index 8e9e539e..4f122484 100644
--- a/chicken.h
+++ b/chicken.h
@@ -572,6 +572,7 @@ typedef unsigned __int64 uint64_t;
#define C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR 32
#define C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR 33
#define C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR 34
+#define C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR 35
/* Platform information */
diff --git a/library.scm b/library.scm
index fcc476d5..7e45b9bf 100644
--- a/library.scm
+++ b/library.scm
@@ -3728,6 +3728,7 @@ EOF
((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer" args))
((33) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))
((34) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))
+ ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - invalid base" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
diff --git a/manual/Extensions to the standard b/manual/Extensions to the standard
index 51e8664b..7b88a0b5 100644
--- a/manual/Extensions to the standard
+++ b/manual/Extensions to the standard
@@ -157,6 +157,11 @@ The latter is encoded in UTF-8 format.
The third argument to {{substring}} is optional and defaults to the length
of the string.
+=== Number/String conversions
+
+The optional "base" argument to{{string->number}} and {{number->string}}
+may be any integral value from 2 to 36.
+
=== {{force}}
{{force}} called with an argument that is not a promise returns
diff --git a/runtime.c b/runtime.c
index 6959a83f..c7214f47 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1582,6 +1582,11 @@ void barf(int code, char *loc, ...)
c = 1;
break;
+ case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:
+ msg = C_text("bad argument type - invalid base");
+ c = 1;
+ break;
+
default: panic(C_text("illegal internal error code"));
}
@@ -7038,7 +7043,7 @@ void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str,
va_end(v);
if(radix & C_FIXNUM_BIT) radix = C_unfix(radix);
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->number", radix);
+ else barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "string->number", radix);
}
else C_bad_argc(c, 3);
@@ -7215,18 +7220,17 @@ C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word
}
}
-
-static char *to_binary(C_uword num)
+static char *to_n_nary(C_uword num, C_uword base)
{
char *p;
-
- buffer[ 66 ] = '\0';
+ char digits[] ={ '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F' };
+ buffer [ 66 ] = '\0';
p = buffer + 66;
-
+
do {
- *(--p) = (num & 1) ? '1' : '0';
- num /= 2;
- } while(num);
+ *(--p) = digits [ num % base ];
+ num /= base;
+ } while (num);
return p;
}
@@ -7247,7 +7251,7 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
va_end(v);
if(radix & C_FIXNUM_BIT) radix = C_unfix(radix);
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", radix);
+ else barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
}
else C_bad_argc(c, 3);
@@ -7259,11 +7263,11 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
num = -num;
}
+ if((radix < 2) || (radix > 16)){
+ barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
+ }
+
switch(radix) {
- case 2:
- p = to_binary(num);
- break;
-
#ifdef C_SIXTY_FOUR
case 8: C_sprintf(p = buffer + 1, C_text("%lo"), num); break;
case 10: C_sprintf(p = buffer + 1, C_text("%ld"), num); break;
@@ -7273,8 +7277,8 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
case 10: C_sprintf(p = buffer + 1, C_text("%d"), num); break;
case 16: C_sprintf(p = buffer + 1, C_text("%x"), num); break;
#endif
-
- default: barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", C_fix(radix));
+ default:
+ p = to_n_nary(num, radix);
}
}
else if(!C_immediatep(num) && C_block_header(num) == C_FLONUM_TAG) {
@@ -7286,11 +7290,11 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
f = -f;
}
- switch(radix) {
- case 2:
- p = to_binary((unsigned int)f);
- goto fini;
+ if((radix < 2) || (radix > 16)){
+ barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
+ }
+ switch(radix) {
case 8:
C_sprintf(p = buffer, "%o", (unsigned int)f);
goto fini;
@@ -7298,6 +7302,11 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
case 16:
C_sprintf(p = buffer, "%x", (unsigned int)f);
goto fini;
+
+ default:
+ p = to_n_nary((unsigned int)f, radix);
+ goto fini;
+
}
}
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index ec59bf60..a58b5960 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -1,5 +1,7 @@
;;;; library-tests.scm
+(use srfi-1)
+
;; numbers
@@ -35,6 +37,13 @@
(99.2 10)
(-99.2 10)))
+;; by Christian Kellermann
+(assert
+ (equal?
+ (map (lambda (n) (number->string 32 n)) (iota 15 2))
+ '("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2A" "28" "26" "24" "22" "20")))
+
+
;; fp-math
(assert (= (sin 42.0) (fpsin 42.0)))
@@ -59,4 +68,3 @@
(assert (= -42.0 (fpceiling -42.2)))
(assert (not (fpinteger? 2.3)))
(assert (fpinteger? 1.0))
-
Trap