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

Add missing fender to define-cstruct

Browse Source 
prevents internal error from libffi for
(define-cstruct _S ())
This commit is contained in:
Tobias Hammer 2013-08-27 17:15:46 +02:00 committed by Matthew Flatt
parent 0e02b7e368
commit 0b1f96ab3d
4 changed files with 20 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/racket-pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -946,7 +946,7 @@ string carries its size information.}
@section{C Struct Types}
@defproc[(make-cstruct-type [types (listof ctype?)]
@defproc[(make-cstruct-type [types (non-empty-listof ctype?)]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[alignment (or/c #f 1 2 4 8 16) #f])
ctype?]{
@ -980,7 +980,7 @@ below for a more efficient approach.}
@defform/subs[(define-cstruct id/sup ([field-id type-expr] ...) property ...)
[(id/sup _id
(_id super-id))
(_id _super-id))
(property (code:line #:alignment alignment-expr)
(code:line #:property prop-expr val-expr)
#:no-equal)]]{
@ -991,7 +991,8 @@ marshaling them to Racket values. The syntax is similar to
@racket[define-struct], providing accessor functions for raw struct
values (which are pointer objects); the @racket[_id]
must start with @litchar{_}, and at most one @racket[#:alignment]
can be supplied.
can be supplied. If no @racket[_super-id] is provided, then at least one
field must be specified.
The resulting bindings are as follows:

18
racket/collects/ffi/unsafe.rkt
View File

@ -1315,10 +1315,11 @@
;; Simple structs: call this with a list of types, and get a type that marshals
;; C structs to/from Scheme lists.
(define* (_list-struct #:alignment [alignment #f] . types)
(define* (_list-struct #:alignment [alignment #f] type . types)
(let ([stype (make-cstruct-type types #f alignment)]
[offsets (compute-offsets types alignment)]
[len (length types)])
[len (add1 (length types))]
[types (cons type types)])
(make-ctype stype
(lambda (vals)
(unless (list? vals)
@ -1588,6 +1589,8 @@
stx xs))
(syntax-case stx ()
[(_ type ([slot slot-type] ...) . more)
(or (stx-pair? #'type)
(stx-pair? #'(slot ...)))
(let-values ([(_TYPE _SUPER)
(syntax-case #'type ()
[(t s) (values #'t #'s)]
@ -1629,13 +1632,13 @@
#'x)]
[else (err "bad syntax")]))])
(unless (identifier? _TYPE)
(err "bad type, expecting a _name identifier or (_name super-ctype)"
(err "expecting a `_name' identifier or `(_name _super-name)'"
_TYPE))
(unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE)))
(err "cstruct name must begin with a `_'" _TYPE))
(for ([s (in-list (syntax->list #'(slot ...)))])
(unless (identifier? s)
(err "bad field name, expecting an identifier identifier" s)))
(err "bad field name, expecting an identifier" s)))
(if _SUPER
(make-syntax _TYPE #t
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
@ -1646,13 +1649,16 @@
no-equal?)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...)
alignment properties property-bindings no-equal?)))]
[(_ type () . more)
(identifier? #'type)
(err "must have either a supertype or at least one field")]
;; specific errors for bad slot specs, leave the rest for a generic error
[(_ type (bad ...) . more)
(err "bad slot specification, expecting [name ctype]"
(err "bad field specification, expecting `[name ctype]'"
(ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s]))
(syntax->list #'(bad ...))))]
[(_ type bad . more)
(err "bad slot specification, expecting a sequence of [name ctype]"
(err "bad field specification, expecting a sequence of `[name ctype]'"
#'bad)]))
;; Add `prop:equal+hash' to use pointer equality

4
racket/src/foreign/foreign.c
View File

@ -1281,7 +1281,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
if (nargs < 0) scheme_wrong_contract(MYNAME, "list?", 0, argc, argv);
if (nargs <= 0) scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
if (!SCHEME_FALSEP(argv[2])) {
@ -1301,7 +1301,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
elements[nargs] = NULL;
for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
scheme_wrong_contract(MYNAME, "(listof ctype?)", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
wrong_void(MYNAME, SCHEME_CAR(p), 1, 0, argc, argv);
elements[i] = CTYPE_PRIMTYPE(base);

4
racket/src/foreign/foreign.rktc
View File

@ -1107,7 +1107,7 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
if (nargs < 0) scheme_wrong_contract(MYNAME, "list?", 0, argc, argv);
if (nargs <= 0) scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
if (!SCHEME_FALSEP(argv[2])) {
@ -1127,7 +1127,7 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
elements[nargs] = NULL;
for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
scheme_wrong_contract(MYNAME, "(listof ctype?)", 0, argc, argv);
scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
wrong_void(MYNAME, SCHEME_CAR(p), 1, 0, argc, argv);
elements[i] = CTYPE_PRIMTYPE(base);