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

add `prop:cpointer'

Browse Source 
Extend `define-cstruct' to support #:property specs, which causes
the constructor and C->Racket coercsions to wrap the pointer in
a structure instance with the specified properties. Of course,
the wrapper structure has a `prop:cpointer' property so that the
wrapper can be used transparently as a C pointer.

Add missing tests and documentation for the id`->list', `list->'id,
id`->list*', and `list*->'id bindings created by `define-cstruct'.
This commit is contained in:
Matthew Flatt 2012-02-14 14:22:56 -07:00
parent 2493564a35
commit 6cd2e3c71b
20 changed files with 660 additions and 323 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

267
collects/ffi/unsafe.rkt
View File

@ -7,7 +7,8 @@
(provide ctype-sizeof ctype-alignof compiler-sizeof
malloc free end-stubborn-change
cpointer? ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
cpointer? prop:cpointer
ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
vector->cpointer flvector->cpointer saved-errno lookup-errno
ctype? make-ctype make-cstruct-type make-array-type make-union-type
@ -1067,7 +1068,11 @@
(syntax-case stx ()
[(_ cptr tag)
#'(let ([ptag (cpointer-tag cptr)])
(if (pair? ptag) (memq tag ptag) (eq? tag ptag)))]
(if (pair? ptag)
(if (null? (cdr ptag))
(eq? tag (car ptag))
(and (memq tag ptag) #t))
(eq? tag ptag)))]
[id (identifier? #'id)
#'(lambda (cptr tag) (cpointer-has-tag? cptr tag))]))
(define-syntax (cpointer-push-tag! stx)
@ -1261,7 +1266,8 @@
;; type.
(provide define-cstruct)
(define-syntax (define-cstruct stx)
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx alignment-stx)
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx
alignment-stx property-stxes)
(define name
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
(define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
@ -1286,6 +1292,7 @@
[(slot ...) slot-names-stx]
[(slot-type ...) slot-types-stx]
[TYPE (id name)]
[cpointer:TYPE (id "cpointer:"name)]
[_TYPE _TYPE-stx]
[_TYPE-pointer (id "_"name"-pointer")]
[_TYPE-pointer/null (id "_"name"-pointer/null")]
@ -1293,6 +1300,12 @@
[_TYPE* (id "_"name"*")]
[TYPE? (id name"?")]
[make-TYPE (id "make-"name)]
[make-wrap-TYPE (if (null? property-stxes)
#'values
(id "make-wrap-"name))]
[wrap-TYPE-type (if (null? property-stxes)
#'values
(id "wrap-"name "-type"))]
[list->TYPE (id "list->"name)]
[list*->TYPE (id "list*->"name)]
[TYPE->list (id name"->list")]
@ -1310,7 +1323,24 @@
(safe-id=? 1st-type #'_TYPE-pointer))
#'(values #f '() #f #f #f #f)
#`(cstruct-info #,1st-type
(lambda () (values #f '() #f #f #f #f))))])
(lambda () (values #f '() #f #f #f #f))))]
[define-wrapper-struct (if (null? property-stxes)
#'(begin)
(with-syntax ([(prop ...) property-stxes])
#'(define make-wrap-TYPE
(let ()
(struct cpointer:TYPE (ptr)
#:property prop:cpointer 0
prop ...)
cpointer:TYPE))))]
[define-wrap-type (if (null? property-stxes)
#'(begin)
#'(define (wrap-TYPE-type t)
(make-ctype t
values
(lambda (p)
(and p
(make-wrap-TYPE p))))))])
#'(begin
(define-syntax TYPE
(make-struct-info
@ -1328,103 +1358,106 @@
super->list* list*->super)
get-super-info])
(define-cpointer-type _TYPE super-pointer)
;; these makes it possible to use recursive pointer definitions
(define _TYPE-pointer _TYPE)
(define _TYPE-pointer/null _TYPE/null)
(let*-values ([(stype ...) (values slot-type ...)]
[(types) (list stype ...)]
[(alignment-v) alignment]
[(offsets) (compute-offsets types alignment-v)]
[(offset ...) (apply values offsets)])
(define all-tags (cons TYPE-tag super-tags))
(define _TYPE*
;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types #f alignment-v)]
[t (_cpointer TYPE-tag cst)]
[c->s (ctype-c->scheme t)])
(make-ctype cst (ctype-scheme->c t)
;; hack: modify & reuse the procedure made by _cpointer
(lambda (p)
(if p (set-cpointer-tag! p all-tags) (c->s p))
p))))
(define-values (all-types all-offsets)
(if (and has-super? super-types super-offsets)
(values (append super-types (cdr types))
(append super-offsets (cdr offsets)))
(values types offsets)))
(define (TYPE-SLOT x)
(unless (TYPE? x)
(raise-type-error 'TYPE-SLOT struct-string x))
(ptr-ref x stype 'abs offset))
...
(define (set-TYPE-SLOT! x slot)
(unless (TYPE? x)
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
(ptr-set! x stype 'abs offset slot))
...
(define make-TYPE
(if (and has-super? super-types super-offsets)
;; init using all slots
(lambda vals
(if (= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each (lambda (type ofs value)
(ptr-set! block type 'abs ofs value))
all-types all-offsets vals)
block)
(error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)))
;; normal initializer
(lambda (slot ...)
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(ptr-set! block stype 'abs offset slot)
...
block))))
(define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals)
(cond
[(TYPE? vals) vals]
[(= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each
(lambda (type ofs value)
(let-values
([(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value))))
all-types all-offsets vals)
block)]
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)]))
(define (TYPE->list x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets))
(define (TYPE->list* x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs)
(let-values
([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(if T->list* (T->list* v) v)))
all-types all-offsets))
(cstruct-info
_TYPE* 'set!
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*))))))))
define-wrap-type
;; these make it possible to use recursive pointer definitions
(define _TYPE-pointer (wrap-TYPE-type _TYPE))
(define _TYPE-pointer/null (wrap-TYPE-type _TYPE/null))
(define-values (stype ...) (values slot-type ...))
(define types (list stype ...))
(define alignment-v alignment)
(define offsets (compute-offsets types alignment-v))
(define-values (offset ...) (apply values offsets))
(define all-tags (cons TYPE-tag super-tags))
(define _TYPE*
;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types #f alignment-v)]
[t (_cpointer TYPE-tag cst)]
[c->s (ctype-c->scheme t)])
(wrap-TYPE-type
(make-ctype cst (ctype-scheme->c t)
;; hack: modify & reuse the procedure made by _cpointer
(lambda (p)
(if p (set-cpointer-tag! p all-tags) (c->s p))
p)))))
(define-values (all-types all-offsets)
(if (and has-super? super-types super-offsets)
(values (append super-types (cdr types))
(append super-offsets (cdr offsets)))
(values types offsets)))
(define (TYPE-SLOT x)
(unless (TYPE? x)
(raise-type-error 'TYPE-SLOT struct-string x))
(ptr-ref x stype 'abs offset))
...
(define (set-TYPE-SLOT! x slot)
(unless (TYPE? x)
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
(ptr-set! x stype 'abs offset slot))
...
(define make-TYPE
(if (and has-super? super-types super-offsets)
;; init using all slots
(lambda vals
(if (= (length vals) (length all-types))
(let ([block (make-wrap-TYPE (malloc _TYPE*))])
(set-cpointer-tag! block all-tags)
(for-each (lambda (type ofs value)
(ptr-set! block type 'abs ofs value))
all-types all-offsets vals)
block)
(error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)))
;; normal initializer
(lambda (slot ...)
(let ([block (make-wrap-TYPE (malloc _TYPE*))])
(set-cpointer-tag! block all-tags)
(ptr-set! block stype 'abs offset slot)
...
block))))
define-wrapper-struct
(define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals)
(cond
[(TYPE? vals) vals]
[(= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each
(lambda (type ofs value)
(let-values
([(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value))))
all-types all-offsets vals)
block)]
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)]))
(define (TYPE->list x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets))
(define (TYPE->list* x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs)
(let-values
([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(if T->list* (T->list* v) v)))
all-types all-offsets))
(cstruct-info
_TYPE* 'set!
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
(define (err what . xs)
(apply raise-syntax-error #f
(if (list? what) (apply string-append what) what)
@ -1435,15 +1468,23 @@
(syntax-case #'type ()
[(t s) (values #'t #'s)]
[_ (values #'type #f)])]
[(alignment)
(syntax-case #'more ()
[() #'#f]
[(#:alignment) (err "missing expression for #:alignment")]
[(#:alignment a) #'a]
[(#:alignment a x . _) (err "unexpected form" #'x)]
[(x . _) (err (if (keyword? (syntax-e #'x))
"unknown keyword" "unexpected form")
#'x)])])
[(alignment properties)
(let loop ([more #'more] [alignment #f] [properties null])
(define (head) (syntax-case more () [(x . _) #'x]))
(syntax-case more ()
[() (values alignment (reverse properties))]
[(#:alignment) (err "missing expression for #:alignment" (head))]
[(#:alignment a . rest)
(not alignment)
(loop #'rest #'a properties)]
[(#:property) (err "missing property expression for #:property" (head))]
[(#:property prop) (err "missing value expression for #:property" (head))]
[(#:property prop val . rest)
(loop #'rest alignment (list* #'val #'prop (head) properties))]
[(x . _) (err (if (keyword? (syntax-e #'x))
"unknown keyword" "unexpected form")
#'x)]
[else (err "bad syntax")]))])
(unless (identifier? _TYPE)
(err "bad type, expecting a _name identifier or (_name super-ctype)"
_TYPE))
@ -1456,8 +1497,10 @@
(make-syntax _TYPE #t
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
#`(#,_SUPER slot-type ...)
alignment)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))]
alignment
properties)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...)
alignment properties)))]
;; specific errors for bad slot specs, leave the rest for a generic error
[(_ type (bad ...) . more)
(err "bad slot specification, expecting [name ctype]"

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

@ -7,9 +7,9 @@
Returns @racket[#t] if @racket[v] is a C pointer or a value that can
be used as a pointer: @racket[#f] (used as a @cpp{NULL} pointer), byte
strings (used as memory blocks), or some additional internal objects
(@racket[ffi-obj]s and callbacks, see @secref["foreign:c-only"]).
Returns @racket[#f] for other values.}
strings (used as memory blocks), or a structure instance with the
@racket[prop:cpointer] @tech[#:doc reference.scrbl]{structure type
property}. Returns @racket[#f] for other values.}
@defproc[(ptr-equal? [cptr1 cpointer?] [cptr2 cpointer?]) boolean?]{
@ -373,3 +373,22 @@ offset is immediately added to the pointer. Thus, this function cannot
be used with @racket[ptr-add] to create a substring of a Racket byte
string, because the offset pointer would be to the middle of a
collectable object (which is not allowed).}
@; ----------------------------------------------------------------------
@section{Pointer Structure Property}
@defthing[prop:cpointer struct-type-property?]{
A @tech[#:doc reference.scrbl]{structure type property} that causes
instances of a structure type to work as C pointer values. The
property value must be either an exact non-negative integer indicating
an immutable field in the structure (which must, in turn, be
initialized to a C pointer value), a procedure that takes the
structure instance and returns a C pointer value, or a C pointer
value.
The @racket[prop:cpointer] property allows a structure instance to be
used transparently as a C pointer value, or it allows a C pointer
value to be transparently wrapped by a structure that may have
additional values or properties.}

50
collects/scribblings/foreign/types.scrbl
View File

@ -844,19 +844,19 @@ the allocated space, so it is inefficient. Use @racket[define-cstruct]
below for a more efficient approach.}
@defform/subs[(define-cstruct id/sup ([field-id type-expr] ...) alignment)
@defform/subs[(define-cstruct id/sup ([field-id type-expr] ...) property ...)
[(id/sup _id
(_id super-id))
(alignment code:blank
(code:line #:alignment alignment-expr))]]{
(property (code:line #:alignment alignment-expr)
(code:line #:property prop-expr val-expr))]]{
Defines a new C struct type, but unlike @racket[_list-struct], the
resulting type deals with C structs in binary form, rather than
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 new type uses pointer tags to
guarantee that only proper struct objects are used. The @racket[_id]
must start with @litchar{_}.
values (which are pointer objects); the @racket[_id]
must start with @litchar{_}, and at most one @racket[#:alignment]
can be supplied.
The resulting bindings are as follows:
@ -867,6 +867,10 @@ The resulting bindings are as follows:
@item{@racket[_id]@racketidfont{-pointer}: a pointer type that should
be used when a pointer to values of this struct are used.}
@item{@racket[_id]@racketidfont{-pointer/null}: like
@racket[_id]@racketidfont{-pointer}, but allowing NULL pointers (as
represented on the Racket side by @racket[#f]).}
@item{@racketvarfont{id}@racketidfont{?}: a predicate for the new type.}
@item{@racketvarfont{id}@racketidfont{-tag}: the tag object that is
@ -875,10 +879,10 @@ The resulting bindings are as follows:
symbol and other symbols, such as the @racketvarfont{super-id} symbol.}
@item{@racketidfont{make-}@racketvarfont{id} : a constructor, which expects
an argument for each type.}
an argument for each field.}
@item{@racketvarfont{id}@racketidfont{-}@racket[field-id] : an accessor
function for each @racket[field-id]; if the field has a cstruct type, then
function for each @racket[field-id]; if the field has a C struct type, then
the result of the accessor is a pointer to the field within the
enclosing structure, rather than a copy of the field.}
@ -886,12 +890,20 @@ The resulting bindings are as follows:
: a mutator function for each @racket[field-id].}
@item{@racketvarfont{id}: structure-type information compatible with
@racket[struct-out] or @racket[match] (but not @racket[define-struct]);
@racket[struct-out] or @racket[match] (but not @racket[struct] or
@racket[define-struct]);
currently, this information is correct only when no @racket[super-id]
is specified.}
@item{@racketvarfont{id}->list : a function that converts a struct into
a list of values.}
@item{@racketvarfont{id}@racketidfont{->list},
@racketidfont{list->}@racketvarfont{id} : a function that converts a
struct into a list of field values and vice versa.}
@item{@racketvarfont{id}@racketidfont{->list*},
@racketidfont{list*->}@racketvarfont{id} : like
@racketvarfont{id}@racketidfont{->list},
@racketidfont{list->}@racketvarfont{id}, but fields that are structs
are recursively unpacked to lists or packed from lists.}
]
@ -906,14 +918,22 @@ should not be used when a pointer is expected, since it will cause the
struct to be copied rather than use the pointer value, leading to
memory corruption.
If the first field is itself a cstruct type, its tag will be used in
Instances of the new type are not normally Racket structure instances.
However, if at least one @racket[#:property] modifier is specified,
then struct creation and coercions from @racket[_id] variants wrap a
non-NULL C pointer representation in a Racket structure that has the
specified properties. The wrapper Racket structure also has a
@racket[prop:cpointer] property, so that wrapped C pointers can be
treated the same as unwrapped C pointers.
If the first field is itself a C struct type, its tag will be used in
addition to the new tag. This feature supports common cases of object
inheritance, where a sub-struct is made by having a first field that
is its super-struct. Instances of the sub-struct can be considered as
instances of the super-struct, since they share the same initial
layout. Using the tag of an initial cstruct field means that the same
layout. Using the tag of an initial C struct field means that the same
behavior is implemented in Racket; for example, accessors and mutators
of the super-cstruct can be used with the new sub-cstruct. See the
of the super-struct can be used with the new sub-struct. See the
example below.
Providing a @racket[super-id] is shorthand for using an initial field
@ -929,7 +949,7 @@ arguments for each of @racketidfont{_}@racket[super-id]'s fields, in
addition for the new fields. This adjustment of the constructor is,
again, in analogy to using a supertype with @racket[define-struct].
Note that structs are allocated as atomic blocks, which means that the
Structs are allocated as atomic blocks, which means that the
garbage collector ignores their content. Thus, struct fields can hold
only non-pointer values, pointers to memory outside the GC's control,
and otherwise-reachable pointers to immobile GC-managed values (such

4
collects/scribblings/foreign/utils.rkt
View File

@ -16,6 +16,7 @@
(provide cpp
InsideRacket InsideRacket-doc
guide.scrbl
reference.scrbl
->>
(all-from-out scribble/manual)
(for-label (all-from-out racket/base
@ -32,6 +33,9 @@
(define guide.scrbl
'(lib "scribblings/guide/guide.scrbl"))
(define reference.scrbl
'(lib "scribblings/reference/reference.scrbl"))
(define-syntax ->>
(make-element-id-transformer
(lambda (stx)

1
collects/tests/racket/all.rktl
View File

@ -6,4 +6,5 @@
(load-relative "syntax-tests.rktl")
(load-in-sandbox "version.rktl")
(load-in-sandbox "foreign-test.rktl")
(load-in-sandbox "cstruct.rktl")
(load-in-sandbox "uni-norm.rktl")

76
collects/tests/racket/cstruct.rktl Normal file
View File

@ -0,0 +1,76 @@
(load-relative "loadtest.rktl")
(Section 'cstruct)
(require ffi/unsafe)
(let ()
(define-syntax-rule (make-test [t-prop ...] t-more
[q-prop ...] q-more)
(begin
(define-cstruct _tri ([x _int] [y _short] [z _short])
t-prop ...)
(define tv (make-tri 1 2 3))
(define tv2 (list->tri '(4 5 6)))
(test 1 tri-x tv)
(test 2 tri-y tv)
(test 3 tri-z tv)
(test 6 tri-z tv2)
(test '(4 5 6) tri->list tv2)
(test '(4 5 6) tri->list* tv2)
(test '(7 8 9) tri->list* (list*->tri '(7 8 9)))
(test #t tri? tv)
(test #f tri? 'tv)
(test #f tri? (cast 1 _intptr _pointer))
(t-more tv)
(t-more tv2)
(define tv3 (cast tv _tri-pointer _tri-pointer))
(t-more tv3)
(define-cstruct (_quad _tri) ([q _double])
q-prop ...)
(define qv (make-quad 10 20 30 40.0))
(test 10 tri-x qv)
(test 20 tri-y qv)
(test 30 tri-z qv)
(test 40.0 quad-q qv)
(test #t tri? tv)
(test #f tri? 'tv)
(test #f tri? (cast 1 _intptr _pointer))
(q-more qv)
(define-cstruct _quint ([pre _quad]
[r _float]))
(define kv (make-quint qv 500.0))
(test 10 tri-x kv)
(test 20 tri-y kv)
(test 30 tri-z kv)
(test 40.0 quad-q kv)
(test 500.0 quint-r kv)
(test 500.0 cadr (quint->list kv))
(test '((10 20 30 40.0) 500.0) quint->list* kv)
(test '((11 21 31 40.25) 500.25) quint->list* (list*->quint '((11 21 31 40.25) 500.25)))))
(make-test [] void
[] void)
(make-test [#:property prop:procedure (lambda (self) self)]
(lambda (tv)
(test tv tv))
[#:property prop:evt always-evt]
(lambda (qv)
(test always-evt sync qv))))
(syntax-test #'(define-cstruct))
(syntax-test #'(define-cstruct _x))
(syntax-test #'(define-cstruct #f))
(syntax-test #'(define-cstruct x ()))
(syntax-test #'(define-cstruct #f ()))
(syntax-test #'(define-cstruct _y (y)))
(syntax-test #'(define-cstruct _y () #:alignment))
(syntax-test #'(define-cstruct _y () #:property))
(syntax-test #'(define-cstruct _y () #:property x))
(syntax-test #'(define-cstruct _y () #:property x y . 10))
(report-errs)

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 5.2.1.6
Added prop:cpointer
Version 5.2.1.5
Added racket/future to re-exports of racket
Changed current-write-relative-directory to support a pair

213
src/foreign/foreign.c
View File

@ -1378,10 +1378,57 @@ END_XFORM_SKIP;
#define scheme_make_foreign_offset_external_cpointer(x, delta) \
((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL))
static int check_cpointer_property(Scheme_Object *v)
{
if (SCHEME_CHAPERONE_STRUCTP(v)
&& scheme_struct_type_property_ref(scheme_cpointer_property, v))
return 1;
else
return 0;
}
static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
{
Scheme_Object *v = orig_v, *val;
int must = 0;
while (1) {
if (SCHEME_CHAPERONE_STRUCTP(v)) {
val = scheme_struct_type_property_ref(scheme_cpointer_property, v);
if (val) {
if (SCHEME_INTP(val))
v = scheme_struct_ref(v, SCHEME_INT_VAL(val));
else if (SCHEME_PROCP(v)) {
Scheme_Object *a[1];
a[0] = v;
v = _scheme_apply(val, 1, a);
} else
v = val;
must = 1;
} else
break;
} else
break;
}
if (must && !SCHEME_FFIANYPTRP(v)) {
scheme_wrong_type("prop:cpointer accessor", "cpointer", 0, -1, &v);
return NULL;
}
return v;
}
int scheme_is_cpointer(Scheme_Object *cp) {
return (SCHEME_FFIANYPTRP(cp) || check_cpointer_property(cp));
}
#define MYNAME "cpointer?"
static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
{
return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
return (scheme_is_cpointer(argv[0])
? scheme_true
: scheme_false);
}
#undef MYNAME
@ -1389,9 +1436,11 @@ static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
{
Scheme_Object *tag = NULL;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]);
if (SCHEME_CPTRP(cp)) tag = SCHEME_CPTR_TYPE(cp);
return (tag == NULL) ? scheme_false : tag;
}
#undef MYNAME
@ -1399,9 +1448,11 @@ static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
#define MYNAME "set-cpointer-tag!"
static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[])
{
if (!SCHEME_CPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPTRP(cp))
scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
SCHEME_CPTR_TYPE(argv[0]) = argv[1];
SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void;
}
#undef MYNAME
@ -1503,6 +1554,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type);
}
val = unwrap_cpointer_property(val);
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
@ -2084,6 +2136,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
void *(*mf)(size_t);
for (i=0; i<argc; i++) {
a = argv[i];
a = unwrap_cpointer_property(argv[i]);
if (SCHEME_INTP(a)) {
if (num != 0)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
@ -2148,10 +2201,12 @@ static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[
{
void *ptr;
intptr_t poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
@ -2167,10 +2222,12 @@ static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
{
void *ptr;
intptr_t poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
free(W_OFFSET(ptr, poff));
@ -2194,10 +2251,12 @@ static Scheme_Object *foreign_free_immobile_cell(int argc, Scheme_Object *argv[]
{
void *ptr;
intptr_t poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
@ -2217,11 +2276,13 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
int argc, Scheme_Object **argv)
{
intptr_t noff;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (is_bang) {
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
} else {
if (!SCHEME_FFIANYPTRP(argv[0]))
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", 0, argc, argv);
}
if (!scheme_get_int_val(argv[1], &noff))
@ -2236,19 +2297,19 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
scheme_wrong_type(who, "C-type", 2, argc, argv);
}
if (is_bang) {
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
((Scheme_Offset_Cptr*)(cp))->offset += noff;
return scheme_void;
} else {
if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
if (SCHEME_CPTRP(cp) && (SCHEME_CPTR_FLAGS(cp) & 0x1))
return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
(SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
else
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
(SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
}
}
@ -2272,7 +2333,9 @@ static Scheme_Object *foreign_ptr_add_bang(int argc, Scheme_Object *argv[])
#define MYNAME "offset-ptr?"
static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[])
{
return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
return (SCHEME_CPOINTER_W_OFFSET_P(cp)) ? scheme_true : scheme_false;
}
#undef MYNAME
@ -2281,9 +2344,11 @@ static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[])
#define MYNAME "ptr-offset"
static Scheme_Object *foreign_ptr_offset(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0]));
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(cp));
}
#undef MYNAME
@ -2294,7 +2359,9 @@ static Scheme_Object *foreign_ptr_offset(int argc, Scheme_Object *argv[])
static Scheme_Object *foreign_set_ptr_offset_bang(int argc, Scheme_Object *argv[])
{
intptr_t noff;
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff)) {
scheme_wrong_type(MYNAME, C_INTPTR_T_TYPE_STR, 1, argc, argv);
@ -2311,7 +2378,7 @@ static Scheme_Object *foreign_set_ptr_offset_bang(int argc, Scheme_Object *argv[
} else
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
}
((Scheme_Offset_Cptr*)(argv[0]))->offset = noff;
((Scheme_Offset_Cptr*)(cp))->offset = noff;
return scheme_void;
}
#undef MYNAME
@ -2331,6 +2398,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
void *src = NULL, *dest = NULL;
intptr_t soff = 0, doff = 0, count, v, mult = 0;
int i, j, ch = 0, argc1 = argc;
Scheme_Object *cp;
/* arg parsing: last optional ctype, then count, then fill byte for memset,
* then the first and second pointer+offset pair. */
@ -2365,14 +2433,15 @@ static Scheme_Object *do_memop(const char *who, int mode,
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: missing a pointer argument for %s",
who, (j == 0 ? "destination" : "source"));
if (!SCHEME_FFIANYPTRP(argv[i]))
cp = unwrap_cpointer_property(argv[i]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", i, argc, argv);
switch (j) {
case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]);
doff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
doff = SCHEME_FFIANYPTR_OFFSET(cp);
break;
case 1: src = SCHEME_FFIANYPTR_VAL(argv[i]);
soff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
case 1: src = SCHEME_FFIANYPTR_VAL(cp);
soff = SCHEME_FFIANYPTR_OFFSET(cp);
break;
}
i++;
@ -2450,12 +2519,13 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
{
int size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if (!is_gcable_pointer(argv[0]))
ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(cp);
if (!is_gcable_pointer(cp))
gcsrc = 0;
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
@ -2464,9 +2534,9 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (SCHEME_FFIOBJP(argv[0])) {
if (SCHEME_FFIOBJP(cp)) {
/* The ffiobj pointer is the function pointer. */
ptr = argv[0];
ptr = cp;
delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj);
}
}
@ -2506,10 +2576,12 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
int size=0; void *ptr;
intptr_t delta;
Scheme_Object *val = argv[argc-1], *base;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
@ -2545,13 +2617,16 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
#define MYNAME "ptr-equal?"
static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
{
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp1, *cp2;
cp1 = unwrap_cpointer_property(argv[0]);
cp2 = unwrap_cpointer_property(argv[1]);
if (!SCHEME_FFIANYPTRP(cp1))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!SCHEME_FFIANYPTRP(argv[1]))
if (!SCHEME_FFIANYPTRP(cp2))
scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
return (SAME_OBJ(argv[0],argv[1]) ||
(SCHEME_FFIANYPTR_OFFSETVAL(argv[0])
== SCHEME_FFIANYPTR_OFFSETVAL(argv[1])))
return (SAME_OBJ(cp1, cp2) ||
(SCHEME_FFIANYPTR_OFFSETVAL(cp1)
== SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
? scheme_true : scheme_false;
}
#undef MYNAME
@ -2565,13 +2640,15 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar
* pointer.
* (Should use real byte-strings with new version.) */
intptr_t len;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1],&len))
scheme_wrong_type(MYNAME, "integer in a C intptr_t range", 1, argc, argv);
if (SCHEME_FALSEP(argv[0])) return scheme_false;
if (SCHEME_FALSEP(cp)) return scheme_false;
else return
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]),
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
len, 0);
}
#undef MYNAME
@ -2612,16 +2689,18 @@ void do_ptr_finalizer(void *p, void *finalizer)
* cdefine[register-finalizer 2 3]{
* void *ptr, *old = NULL;
* int ptrsym = (argc == 3 && argv[2] == pointer_sym);
* Scheme_Object *cp;
* cp = unwrap_cpointer_property(argv[0]);
* if (ptrsym) {
* if (!SCHEME_FFIANYPTRP(argv[0]))
* if (!SCHEME_FFIANYPTRP(cp))
* scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
* ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
* ptr = SCHEME_FFIANYPTR_VAL(cp);
* if (ptr == NULL)
* scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
* } else {
* if (argc == 3)
* scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
* ptr = argv[0];
* ptr = cp;
* }
* if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
* scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
@ -2822,7 +2901,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
{
Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base;
Scheme_Object *obj, *data, *p, *base, *cp;
ffi_abi abi;
intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes;
@ -2834,10 +2913,11 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
#else
# define FFI_CALL_VEC_SIZE 7
#endif
if (!SCHEME_FFIANYPTRP(argv[0]))
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
obj = SCHEME_FFIANYPTR_VAL(argv[0]);
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
obj = SCHEME_FFIANYPTR_VAL(cp);
ooff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((obj == NULL) && (ooff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
nargs = scheme_proper_list_length(itypes);
@ -2884,8 +2964,8 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
p = scheme_append_byte_string
(ffi_name_prefix,
scheme_make_byte_string_without_copying
(SCHEME_FFIOBJP(argv[0]) ?
((ffi_obj_struct*)(argv[0]))->name : "proc"));
(SCHEME_FFIOBJP(cp) ?
((ffi_obj_struct*)(cp))->name : "proc"));
SCHEME_VEC_ELS(data)[0] = p;
SCHEME_VEC_ELS(data)[1] = obj;
SCHEME_VEC_ELS(data)[2] = itypes;
@ -3719,6 +3799,7 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
scheme_add_global("_fpointer", (Scheme_Object*)t, menv);
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
}
@ -3727,6 +3808,15 @@ void scheme_init_foreign(Scheme_Env *env)
#else /* DONT_USE_FOREIGN */
int scheme_is_cpointer(Scheme_Object *cp)
{
return (SCHEME_FALSEP(cp)
|| SCHEME_CPTRP(x)
|| SCHEME_BYTE_STRINGP(x)
|| (SCHEME_CHAPERONE_STRUCTP(cp)
&& scheme_struct_type_property_ref(scheme_cpointer_property, cp)));
}
static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who)
{
scheme_signal_error("%s: foreign interface not supported for this platform",
@ -3876,6 +3966,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("_gcpointer", scheme_false, menv);
scheme_add_global("_scheme", scheme_false, menv);
scheme_add_global("_fpointer", scheme_false, menv);
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
}

213
src/foreign/foreign.rktc
View File

@ -1160,22 +1160,73 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
#define scheme_make_foreign_offset_external_cpointer(x, delta) \
((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL))
static int check_cpointer_property(Scheme_Object *v)
{
if (SCHEME_CHAPERONE_STRUCTP(v)
&& scheme_struct_type_property_ref(scheme_cpointer_property, v))
return 1;
else
return 0;
}
static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
{
Scheme_Object *v = orig_v, *val;
int must = 0;
while (1) {
if (SCHEME_CHAPERONE_STRUCTP(v)) {
val = scheme_struct_type_property_ref(scheme_cpointer_property, v);
if (val) {
if (SCHEME_INTP(val))
v = scheme_struct_ref(v, SCHEME_INT_VAL(val));
else if (SCHEME_PROCP(v)) {
Scheme_Object *a[1];
a[0] = v;
v = _scheme_apply(val, 1, a);
} else
v = val;
must = 1;
} else
break;
} else
break;
}
if (must && !SCHEME_FFIANYPTRP(v)) {
scheme_wrong_type("prop:cpointer accessor", "cpointer", 0, -1, &v);
return NULL;
}
return v;
}
int scheme_is_cpointer(Scheme_Object *cp) {
return (SCHEME_FFIANYPTRP(cp) || check_cpointer_property(cp));
}
@cdefine[cpointer? 1]{
return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
return (scheme_is_cpointer(argv[0])
? scheme_true
: scheme_false);
}
@cdefine[cpointer-tag 1]{
Scheme_Object *tag = NULL;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]);
if (SCHEME_CPTRP(cp)) tag = SCHEME_CPTR_TYPE(cp);
return (tag == NULL) ? scheme_false : tag;
}
@cdefine[set-cpointer-tag! 2]{
if (!SCHEME_CPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPTRP(cp))
scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
SCHEME_CPTR_TYPE(argv[0]) = argv[1];
SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void;
}
@ -1256,6 +1307,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type);
}
val = unwrap_cpointer_property(val);
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
@ -1502,6 +1554,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
void *(*mf)(size_t);
for (i=0; i<argc; i++) {
a = argv[i];
a = unwrap_cpointer_property(argv[i]);
if (SCHEME_INTP(a)) {
if (num != 0)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
@ -1563,10 +1616,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
@cdefine[end-stubborn-change 1]{
void *ptr;
intptr_t poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
@ -1579,10 +1634,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
@cdefine[free 1]{
void *ptr;
intptr_t poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
free(W_OFFSET(ptr, poff));
@ -1600,10 +1657,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
@cdefine[free-immobile-cell 1]{
void *ptr;
intptr_t poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
@ -1622,11 +1681,13 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
int argc, Scheme_Object **argv)
{
intptr_t noff;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (is_bang) {
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
} else {
if (!SCHEME_FFIANYPTRP(argv[0]))
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", 0, argc, argv);
}
if (!scheme_get_int_val(argv[1], &noff))
@ -1641,19 +1702,19 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
scheme_wrong_type(who, "C-type", 2, argc, argv);
}
if (is_bang) {
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
((Scheme_Offset_Cptr*)(cp))->offset += noff;
return scheme_void;
} else {
if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
if (SCHEME_CPTRP(cp) && (SCHEME_CPTR_FLAGS(cp) & 0x1))
return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
(SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
else
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
(SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
}
}
@ -1665,15 +1726,19 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
/* (offset-ptr? x) */
/* Returns #t if the argument is a cpointer with an offset */
@cdefine[offset-ptr? 1 1]{
return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
return (SCHEME_CPOINTER_W_OFFSET_P(cp)) ? scheme_true : scheme_false;
}
/* (ptr-offset ptr) */
/* Returns the offset of a cpointer (0 if it's not an offset pointer) */
@cdefine[ptr-offset 1 1]{
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0]));
return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(cp));
}
/* (set-ptr-offset! ptr offset [type]) */
@ -1681,7 +1746,9 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
* the given ctype) */
@cdefine[set-ptr-offset! 2 3]{
intptr_t noff;
if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff)) {
scheme_wrong_type(MYNAME, C_INTPTR_T_TYPE_STR, 1, argc, argv);
@ -1698,7 +1765,7 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
} else
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
}
((Scheme_Offset_Cptr*)(argv[0]))->offset = noff;
((Scheme_Offset_Cptr*)(cp))->offset = noff;
return scheme_void;
}
@ -1717,6 +1784,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
void *src = NULL, *dest = NULL;
intptr_t soff = 0, doff = 0, count, v, mult = 0;
int i, j, ch = 0, argc1 = argc;
Scheme_Object *cp;
/* arg parsing: last optional ctype, then count, then fill byte for memset,
* then the first and second pointer+offset pair. */
@ -1751,14 +1819,15 @@ static Scheme_Object *do_memop(const char *who, int mode,
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: missing a pointer argument for %s",
who, (j == 0 ? "destination" : "source"));
if (!SCHEME_FFIANYPTRP(argv[i]))
cp = unwrap_cpointer_property(argv[i]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", i, argc, argv);
switch (j) {
case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]);
doff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
doff = SCHEME_FFIANYPTR_OFFSET(cp);
break;
case 1: src = SCHEME_FFIANYPTR_VAL(argv[i]);
soff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
case 1: src = SCHEME_FFIANYPTR_VAL(cp);
soff = SCHEME_FFIANYPTR_OFFSET(cp);
break;
}
i++;
@ -1813,12 +1882,13 @@ static Scheme_Object *do_memop(const char *who, int mode,
@cdefine[ptr-ref 2 4]{
int size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if (!is_gcable_pointer(argv[0]))
ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(cp);
if (!is_gcable_pointer(cp))
gcsrc = 0;
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
@ -1827,9 +1897,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (SCHEME_FFIOBJP(argv[0])) {
if (SCHEME_FFIOBJP(cp)) {
/* The ffiobj pointer is the function pointer. */
ptr = argv[0];
ptr = cp;
delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj);
}
}
@ -1866,10 +1936,12 @@ static Scheme_Object *do_memop(const char *who, int mode,
int size=0; void *ptr;
intptr_t delta;
Scheme_Object *val = argv[argc-1], *base;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
@ -1902,13 +1974,16 @@ static Scheme_Object *do_memop(const char *who, int mode,
/* (ptr-equal? cpointer cpointer) -> boolean */
@cdefine[ptr-equal? 2 2]{
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp1, *cp2;
cp1 = unwrap_cpointer_property(argv[0]);
cp2 = unwrap_cpointer_property(argv[1]);
if (!SCHEME_FFIANYPTRP(cp1))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!SCHEME_FFIANYPTRP(argv[1]))
if (!SCHEME_FFIANYPTRP(cp2))
scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
return (SAME_OBJ(argv[0],argv[1]) ||
(SCHEME_FFIANYPTR_OFFSETVAL(argv[0])
== SCHEME_FFIANYPTR_OFFSETVAL(argv[1])))
return (SAME_OBJ(cp1, cp2) ||
(SCHEME_FFIANYPTR_OFFSETVAL(cp1)
== SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
? scheme_true : scheme_false;
}
@ -1919,13 +1994,15 @@ static Scheme_Object *do_memop(const char *who, int mode,
* pointer.
* (Should use real byte-strings with new version.) */
intptr_t len;
if (!SCHEME_FFIANYPTRP(argv[0]))
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1],&len))
scheme_wrong_type(MYNAME, "integer in a C intptr_t range", 1, argc, argv);
if (SCHEME_FALSEP(argv[0])) return scheme_false;
if (SCHEME_FALSEP(cp)) return scheme_false;
else return
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]),
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
len, 0);
}
@ -1966,16 +2043,18 @@ defsymbols[pointer]
cdefine[register-finalizer 2 3]{
void *ptr, *old = NULL;
int ptrsym = (argc == 3 && argv[2] == pointer_sym);
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (ptrsym) {
if (!SCHEME_FFIANYPTRP(argv[0]))
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
ptr = SCHEME_FFIANYPTR_VAL(cp);
if (ptr == NULL)
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
} else {
if (argc == 3)
scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
ptr = argv[0];
ptr = cp;
}
if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
@ -2174,7 +2253,7 @@ static Scheme_Object *ffi_name_prefix = NULL;
@cdefine[ffi-call 3 6]{
Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base;
Scheme_Object *obj, *data, *p, *base, *cp;
ffi_abi abi;
intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes;
@ -2186,10 +2265,11 @@ static Scheme_Object *ffi_name_prefix = NULL;
#else
# define FFI_CALL_VEC_SIZE 7
#endif
if (!SCHEME_FFIANYPTRP(argv[0]))
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
obj = SCHEME_FFIANYPTR_VAL(argv[0]);
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
obj = SCHEME_FFIANYPTR_VAL(cp);
ooff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((obj == NULL) && (ooff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
nargs = scheme_proper_list_length(itypes);
@ -2236,8 +2316,8 @@ static Scheme_Object *ffi_name_prefix = NULL;
p = scheme_append_byte_string
(ffi_name_prefix,
scheme_make_byte_string_without_copying
(SCHEME_FFIOBJP(argv[0]) ?
((ffi_obj_struct*)(argv[0]))->name : "proc"));
(SCHEME_FFIOBJP(cp) ?
((ffi_obj_struct*)(cp))->name : "proc"));
SCHEME_VEC_ELS(data)[0] = p;
SCHEME_VEC_ELS(data)[1] = obj;
SCHEME_VEC_ELS(data)[2] = itypes;
@ -2769,6 +2849,7 @@ void scheme_init_foreign(Scheme_Env *env)
@list{(Scheme_Object*)(void*)(&ffi_type_@ftype)}
@list{(Scheme_Object*)FOREIGN_@cname}]
scheme_add_global("_@stype", (Scheme_Object*)t, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
}
@ -2777,6 +2858,15 @@ void scheme_init_foreign(Scheme_Env *env)
#else /* DONT_USE_FOREIGN */
int scheme_is_cpointer(Scheme_Object *cp)
{
return (SCHEME_FALSEP(cp)
|| SCHEME_CPTRP(x)
|| SCHEME_BYTE_STRINGP(x)
|| (SCHEME_CHAPERONE_STRUCTP(cp)
&& scheme_struct_type_property_ref(scheme_cpointer_property, cp)));
}
static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who)
{
scheme_signal_error("%s: foreign interface not supported for this platform",
@ -2819,6 +2909,7 @@ void scheme_init_foreign(Scheme_Env *env)
(reverse (cfunctions)))
@(map-types
@list{scheme_add_global("_@stype", scheme_false, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
}

1
src/racket/include/mzwin.def
View File

@ -318,6 +318,7 @@ EXPORTS
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

1
src/racket/include/mzwin3m.def
View File

@ -333,6 +333,7 @@ EXPORTS
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

1
src/racket/include/racket.exp
View File

@ -335,6 +335,7 @@ scheme_make_cptr
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

1
src/racket/include/racket3m.exp
View File

@ -341,6 +341,7 @@ scheme_make_cptr
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

2
src/racket/src/schemef.h
View File

@ -624,6 +624,8 @@ MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, intptr_t offset, Sc
MZ_EXTERN Scheme_Object *scheme_make_external_cptr(void *cptr, Scheme_Object *typetag);
MZ_EXTERN Scheme_Object *scheme_make_offset_external_cptr(void *cptr, intptr_t offset, Scheme_Object *typetag);
MZ_EXTERN int scheme_is_cpointer(Scheme_Object *cp);
MZ_EXTERN const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error);
/*========================================================================*/

1
src/racket/src/schemex.h
View File

@ -499,6 +499,7 @@ Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, intptr_t offset, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_external_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_external_cptr)(void *cptr, intptr_t offset, Scheme_Object *typetag);
int (*scheme_is_cpointer)(Scheme_Object *cp);
const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
/*========================================================================*/
/* strings */

1
src/racket/src/schemex.inc
View File

@ -369,6 +369,7 @@
scheme_extension_table->scheme_make_offset_cptr = scheme_make_offset_cptr;
scheme_extension_table->scheme_make_external_cptr = scheme_make_external_cptr;
scheme_extension_table->scheme_make_offset_external_cptr = scheme_make_offset_external_cptr;
scheme_extension_table->scheme_is_cpointer = scheme_is_cpointer;
scheme_extension_table->scheme_get_proc_name = scheme_get_proc_name;
scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode;
scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix;

1
src/racket/src/schemexm.h
View File

@ -369,6 +369,7 @@
#define scheme_make_offset_cptr (scheme_extension_table->scheme_make_offset_cptr)
#define scheme_make_external_cptr (scheme_extension_table->scheme_make_external_cptr)
#define scheme_make_offset_external_cptr (scheme_extension_table->scheme_make_offset_external_cptr)
#define scheme_is_cpointer (scheme_extension_table->scheme_is_cpointer)
#define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name)
#define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode)
#define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix)

1
src/racket/src/schpriv.h
View File

@ -413,6 +413,7 @@ extern Scheme_Object *scheme_default_prompt_tag;
THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel);
extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_cpointer_property;
extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_impersonator_of_property;

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.2.1.5"
#define MZSCHEME_VERSION "5.2.1.6"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

117
src/racket/src/struct.c
View File

@ -31,6 +31,7 @@ READ_ONLY Scheme_Object *scheme_make_arity_at_least;
READ_ONLY Scheme_Object *scheme_source_property;
READ_ONLY Scheme_Object *scheme_input_port_property;
READ_ONLY Scheme_Object *scheme_output_port_property;
READ_ONLY Scheme_Object *scheme_cpointer_property;
READ_ONLY Scheme_Object *scheme_equal_property;
READ_ONLY Scheme_Object *scheme_no_arity_property;
READ_ONLY Scheme_Object *scheme_impersonator_of_property;
@ -96,6 +97,7 @@ static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *arg
static Scheme_Object *check_print_attribute_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_cpointer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_checked_proc_property_value_ok(int argc, Scheme_Object *argv[]);
@ -419,6 +421,16 @@ scheme_init_struct (Scheme_Env *env)
scheme_add_global_constant("prop:output-port", scheme_output_port_property, env);
}
{
REGISTER_SO(scheme_cpointer_property);
guard = scheme_make_prim_w_arity(check_cpointer_property_value_ok,
"guard-for-prop:cpointer",
2, 2);
scheme_cpointer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("cpointer"),
guard);
}
{
REGISTER_SO(rename_transformer_property);
@ -1331,26 +1343,27 @@ static int extract_accessor_offset(Scheme_Object *acc)
return 0;
}
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[])
/* This is the guard for prop:evt */
typedef int (*Check_Val_Proc)(Scheme_Object *);
static Scheme_Object *check_indirect_property_value_ok(const char *name, Check_Val_Proc ck, int proc_ok,
const char *complain,
int argc, Scheme_Object *argv[])
{
Scheme_Object *v, *l, *acc;
int pos, num_islots;
v = argv[0];
if (scheme_is_evt(v))
if (ck(v))
return v;
if (scheme_check_proc_arity(NULL, 1, 0, 1, &v))
if (proc_ok && scheme_check_proc_arity(NULL, 1, 0, 1, &v))
return v;
if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
scheme_arg_mismatch("guard-for-prop:evt",
"property value is not a evt, procedure (arity 1), or exact non-negative integer: ",
v);
scheme_arg_mismatch(name, complain, v);
l = argv[1];
l = SCHEME_CDR(l);
num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
@ -1367,7 +1380,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
pos = SCHEME_INT_VAL(v);
if (pos >= num_islots) {
scheme_arg_mismatch("guard-for-prop:evt",
scheme_arg_mismatch(name,
"field index >= initialized-field count for structure type: ",
v);
}
@ -1378,7 +1391,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
}
if (!SCHEME_PAIRP(l)) {
scheme_arg_mismatch("guard-for-prop:evt",
scheme_arg_mismatch(name,
"field index not declared immutable: ",
v);
}
@ -1389,6 +1402,15 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
return v;
}
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[])
/* This is the guard for prop:evt */
{
return check_indirect_property_value_ok("guard-for-prop:evt",
scheme_is_evt, 1,
"property value is not a evt, procedure (arity 1), or exact non-negative integer: ",
argc, argv);
}
static Scheme_Object *return_wrapped(void *data, int argc, Scheme_Object *argv[])
{
return (Scheme_Object *)data;
@ -1468,61 +1490,6 @@ static int is_evt_struct(Scheme_Object *o)
/* port structs */
/*========================================================================*/
typedef int (*Check_Val_Proc)(Scheme_Object *);
static Scheme_Object *check_indirect_property_value_ok(const char *name, Check_Val_Proc ck, const char *complain,
int argc, Scheme_Object *argv[])
{
Scheme_Object *v, *l, *acc;
int pos, num_islots;
v = argv[0];
if (ck(v))
return v;
if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
scheme_arg_mismatch(name, complain, v);
l = argv[1];
l = SCHEME_CDR(l);
num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
l = SCHEME_CDR(l);
l = SCHEME_CDR(l);
acc = SCHEME_CAR(l);
l = SCHEME_CDR(l);
l = SCHEME_CDR(l);
l = SCHEME_CAR(l);
if (SCHEME_BIGNUMP(v))
pos = num_islots; /* too big */
else
pos = SCHEME_INT_VAL(v);
if (pos >= num_islots) {
scheme_arg_mismatch(name,
"field index >= initialized-field count for structure type: ",
v);
}
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (SCHEME_INT_VAL(SCHEME_CAR(l)) == pos)
break;
}
if (!SCHEME_PAIRP(l)) {
scheme_arg_mismatch(name,
"field index not declared immutable: ",
v);
}
pos += extract_accessor_offset(acc);
v = scheme_make_integer(pos);
return v;
}
static int is_input_port(Scheme_Object *v) { return SCHEME_INPUT_PORTP(v); }
static int is_output_port(Scheme_Object *v) { return SCHEME_OUTPUT_PORTP(v); }
@ -1530,7 +1497,7 @@ static Scheme_Object *check_port_property_value_ok(const char *name, int input,
/* This is the guard for prop:input-port and prop:output-port */
{
return check_indirect_property_value_ok(name,
input ? is_input_port : is_output_port,
input ? is_input_port : is_output_port, 0,
(input
? "property value is not an input port or exact non-negative integer: "
: "property value is not an output port or exact non-negative integer: "),
@ -1547,6 +1514,18 @@ static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Objec
return check_port_property_value_ok("guard-for-prop:output-port", 0, argc, argv);
}
/*========================================================================*/
/* cpointer property */
/*========================================================================*/
static Scheme_Object *check_cpointer_property_value_ok(int argc, Scheme_Object *argv[])
{
return check_indirect_property_value_ok("guard-for-prop:cpointer",
scheme_is_cpointer, 1,
"property value is not a cpointer, procedure (arity 1), or exact non-negative integer: ",
argc, argv);
}
/*========================================================================*/
/* equal+hash property */
/*========================================================================*/
@ -1712,7 +1691,7 @@ Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o)
static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[])
{
return check_indirect_property_value_ok("guard-for-prop:rename-transformer",
is_stx_id,
is_stx_id, 0,
"property value is not an identifier or exact non-negative integer, optionaly boxed: ",
argc, argv);
}
@ -1773,7 +1752,7 @@ Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[])
{
return check_indirect_property_value_ok("guard-for-prop:set!-transformer",
is_proc_1_or_2,
is_proc_1_or_2, 0,
"property value is not an procedure (arity 1 or 2) or exact non-negative integer: ",
argc, argv);
}