~ chicken-core (chicken-5) eb07a140d8959d88aa848b6c79c2469d0b476416
commit eb07a140d8959d88aa848b6c79c2469d0b476416
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jan 14 04:54:32 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jan 14 04:54:32 2011 -0500
foreign-argument checks for 64-bit integer types where insufficient (thanks to Kon Lovett)
diff --git a/chicken.h b/chicken.h
index aa1654f9..af60209e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -776,6 +776,10 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_UWORD_MAX UINT_MAX
#endif
+#define C_WORD64_MIN LLONG_MIN
+#define C_WORD64_MAX LLONG_MAX
+#define C_UWORD64_MAX ULLONG_MAX
+
#ifndef C_PROVIDE_LIBC_STUBS
# define C_FILEPTR FILE *
@@ -1803,6 +1807,8 @@ C_fctexport C_word C_fcall C_i_foreign_pointer_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_integer_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_integer64_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x) C_regparm;
C_fctexport C_char *C_lookup_procedure_id(void *ptr);
C_fctexport void *C_lookup_procedure_ptr(C_char *id);
diff --git a/library.scm b/library.scm
index 22e34e29..df45376b 100644
--- a/library.scm
+++ b/library.scm
@@ -4145,7 +4145,13 @@ EOF
(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))
(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))
(define (##sys#foreign-integer-argument x) (##core#inline "C_i_foreign_integer_argumentp" x))
-(define (##sys#foreign-unsigned-integer-argument x) (##core#inline "C_i_foreign_unsigned_integer_argumentp" x))
+(define (##sys#foreign-integer64-argument x) (##core#inline "C_i_foreign_integer64_argumentp" x))
+
+(define (##sys#foreign-unsigned-integer64-argument x)
+ (##core#inline "C_i_foreign_unsigned_integer64_argumentp" x))
+
+(define (##sys#foreign-unsigned-integer64-argument x)
+ (##core#inline "C_i_foreign_unsigned_integer64_argumentp" x))
;;; Low-level threading interface:
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 4d4e4923..939fce20 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -230,6 +230,12 @@ Binds the parameters {{PARAMETER1 ...}} dynamically to the values
{{make-parameter}} in [[Parameters]]). Note that {{PARAMETER}} may be any
expression that evaluates to a parameter procedure.
+Note: due to a bug in the implementation of {{parameterize}},
+restoring the previous parameter values does reinvoke the guard
+procedure of the parameter, if it has any. If the guard procedure
+performs a conversion, then the conversion will be reinvoked
+on restoration of the old value.
+
==== receive
<macro>(receive (NAME ...) VALUEEXP BODY ...)</macro><br>
diff --git a/runtime.c b/runtime.c
index 03a85f35..18f10b52 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5675,6 +5675,23 @@ C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
}
+C_regparm C_word C_fcall C_i_foreign_integer64_argumentp(C_word x)
+{
+ double m;
+
+ if((x & C_FIXNUM_BIT) != 0) return x;
+
+ if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ m = C_flonum_magnitude(x);
+
+ if(m >= C_WORD64_MIN && m <= C_WORD64_MAX) return x;
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
+ return C_SCHEME_UNDEFINED;
+}
+
+
C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
{
double m;
@@ -5692,6 +5709,23 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
}
+C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
+{
+ double m;
+
+ if((x & C_FIXNUM_BIT) != 0) return x;
+
+ if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ m = C_flonum_magnitude(x);
+
+ if(m >= 0 && m <= C_UWORD64_MAX) return x;
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
+ return C_SCHEME_UNDEFINED;
+}
+
+
/* I */
C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
{
diff --git a/support.scm b/support.scm
index 7eab089b..4c84cd99 100644
--- a/support.scm
+++ b/support.scm
@@ -965,12 +965,18 @@
`(##sys#foreign-struct-wrapper-argument
',(##sys#slot (assq t tmap) 1)
,param) ) ]
- [(integer long size_t integer32 integer64)
+ [(integer long size_t integer32)
(if unsafe param `(##sys#foreign-integer-argument ,param))]
- [(unsigned-integer unsigned-integer32 unsigned-long unsigned-integer64)
+ [(integer64)
+ (if unsafe param `(##sys#foreign-integer64-argument ,param))]
+ [(unsigned-integer unsigned-integer32 unsigned-long)
(if unsafe
param
`(##sys#foreign-unsigned-integer-argument ,param) ) ]
+ [(unsigned-integer32)
+ (if unsafe
+ param
+ `(##sys#foreign-unsigned-integer64-argument ,param) ) ]
[(c-pointer c-string-list c-string-list*)
(let ([tmp (gensym)])
`(let ([,tmp ,param])
Trap