suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

generalize `malloc' to allow a 0-sized request

Browse Source 
Past experience suggests that this is generally better than adding
`zero?' tests at various places that might otherwise call `malloc'.
This commit is contained in:
Matthew Flatt 2012-03-29 14:14:33 -06:00
parent a73b9bb788
commit 738cac3d24
5 changed files with 42 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/ffi/unsafe.rkt
View File

@ -933,7 +933,7 @@
[(_ i t ) (type: _pointer
pre: (x => (list->cblock x t)))]
[(_ o t n) (type: _pointer
pre: (if (zero? n) #f (malloc n t))
pre: (malloc n t)
post: (x => (cblock->list x t n)))]
[(_ io t n) (type: _pointer
pre: (x => (list->cblock x t))
@ -947,7 +947,7 @@
[(_ i t ) (type: _pointer
pre: (x => (vector->cblock x t)))]
[(_ o t n) (type: _pointer
pre: (if (zero? n) #f (malloc n t))
pre: (malloc n t)
post: (x => (cblock->vector x t n)))]
[(_ io t n) (type: _pointer
pre: (x => (vector->cblock x t))

12
collects/scribblings/foreign/pointers.scrbl
View File

@ -217,8 +217,11 @@ can contain other information).}
For general information on C-level memory management with Racket,
see @|InsideRacket|.
@defproc[(malloc [bytes-or-type (or/c exact-nonnegative-integer? ctype?)]
[type-or-bytes (or/c exact-nonnegative-integer? ctype?) @#,elem{absent}]
@defproc[(malloc [bytes-or-type (or/c (and/c exact-nonnegative-integer? fixnum?)
ctype?)]
[type-or-bytes (or/c (and/c exact-nonnegative-integer? fixnum?)
ctype?)
@#,elem{absent}]
[cptr cpointer? @#,elem{absent}]
[mode (one-of/c 'nonatomic 'stubborn 'uncollectable
'eternal 'interior 'atomic-interior
@ -229,8 +232,9 @@ see @|InsideRacket|.
Allocates a memory block of a specified size using a specified
allocation. The result is a @racket[cpointer] to the allocated
memory. Although not reflected above, the four arguments can appear in
any order since they are all different types of Racket objects; a size
memory, or @racket[#f] if the requested size is zero. Although
not reflected above, the four arguments can appear in
any order, since they are all different types of Racket objects; a size
specification is required at minimum:
@itemize[

30
collects/tests/racket/foreign-test.rktl
View File

@ -6,6 +6,10 @@
(require mzlib/foreign)
(unsafe!)
(test #f malloc 0)
(test #f malloc 0 _int)
(test #f malloc _int 0)
(let ([big/little (if (system-big-endian?) (lambda (x y) x) (lambda (x y) y))]
[p (malloc _int32)])
(ptr-set! p _int32 0)
@ -168,18 +172,20 @@
((ffi 'hoho (_fun _int (_fun _int -> (_fun _int -> _int)) -> _int))
3 (lambda (x) (lambda (y) (+ y (* x x))))))
;; ---
(test '(0 1 2 3 4 5 6 7 8 9)
'qsort
((get-ffi-obj 'qsort #f
(_fun (l : (_list io _int len))
(len : _int = (length l))
(size : _int = (ctype-sizeof _int))
(compare : (_fun _pointer _pointer -> _int))
-> _void -> l))
'(7 1 2 3 5 6 4 8 0 9)
(lambda (x y)
(let ([x (ptr-ref x _int)] [y (ptr-ref y _int)])
(cond [(< x y) -1] [(> x y) +1] [else 0])))))
(let ([qsort (get-ffi-obj 'qsort #f
(_fun (l : (_list io _int len))
(len : _int = (length l))
(size : _int = (ctype-sizeof _int))
(compare : (_fun _pointer _pointer -> _int))
-> _void -> l))])
(test '(0 1 2 3 4 5 6 7 8 9)
'qsort
(qsort
'(7 1 2 3 5 6 4 8 0 9)
(lambda (x y)
(let ([x (ptr-ref x _int)] [y (ptr-ref y _int)])
(cond [(< x y) -1] [(> x y) +1] [else 0])))))
(test '() 'qsort (qsort '() (lambda (x y) (error "bad!")))))
;; ---
;; test vectors
(t 55 'grab7th (_fun _pointer -> _int ) #"012345678")

13
src/foreign/foreign.c
View File

@ -2130,7 +2130,7 @@ static Scheme_Object *fail_ok_sym;
static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
{
int i, failok=0;
intptr_t size=0, num=0;
intptr_t size=0, num=-1;
void *from = NULL, *res = NULL;
intptr_t foff = 0;
Scheme_Object *mode = NULL, *a, *base = NULL;
@ -2139,11 +2139,11 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
a = argv[i];
a = unwrap_cpointer_property(argv[i]);
if (SCHEME_INTP(a)) {
if (num != 0)
if (num != -1)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
num = SCHEME_INT_VAL(a);
if (num <= 0)
scheme_wrong_type(MYNAME, "positive fixnum", 0, argc, argv);
if (num < 0)
scheme_wrong_type(MYNAME, "nonnegative fixnum", 0, argc, argv);
} else if (SCHEME_CTYPEP(a)) {
if (size != 0)
scheme_signal_error(MYNAME": specifying a second type: %V", a);
@ -2168,8 +2168,9 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
}
}
if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
if (!num) return scheme_false;
if ((num == -1) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==-1) ? 1 : num);
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;

13
src/foreign/foreign.rktc
View File

@ -1548,7 +1548,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
* when the type is any pointer, otherwise scheme_malloc_atomic is used. */
@cdefine[malloc 1 5]{
int i, failok=0;
intptr_t size=0, num=0;
intptr_t size=0, num=-1;
void *from = NULL, *res = NULL;
intptr_t foff = 0;
Scheme_Object *mode = NULL, *a, *base = NULL;
@ -1557,11 +1557,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
a = argv[i];
a = unwrap_cpointer_property(argv[i]);
if (SCHEME_INTP(a)) {
if (num != 0)
if (num != -1)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
num = SCHEME_INT_VAL(a);
if (num <= 0)
scheme_wrong_type(MYNAME, "positive fixnum", 0, argc, argv);
if (num < 0)
scheme_wrong_type(MYNAME, "nonnegative fixnum", 0, argc, argv);
} else if (SCHEME_CTYPEP(a)) {
if (size != 0)
scheme_signal_error(MYNAME": specifying a second type: %V", a);
@ -1586,8 +1586,9 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
}
}
if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
if (!num) return scheme_false;
if ((num == -1) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==-1) ? 1 : num);
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;