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

93
collects/ffi/unsafe.rkt
View File

@ -7,7 +7,8 @@
(provide ctype-sizeof ctype-alignof compiler-sizeof (provide ctype-sizeof ctype-alignof compiler-sizeof
malloc free end-stubborn-change 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! ptr-offset ptr-add! offset-ptr? set-ptr-offset!
vector->cpointer flvector->cpointer saved-errno lookup-errno vector->cpointer flvector->cpointer saved-errno lookup-errno
ctype? make-ctype make-cstruct-type make-array-type make-union-type ctype? make-ctype make-cstruct-type make-array-type make-union-type
@ -1067,7 +1068,11 @@
(syntax-case stx () (syntax-case stx ()
[(_ cptr tag) [(_ cptr tag)
#'(let ([ptag (cpointer-tag cptr)]) #'(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) [id (identifier? #'id)
#'(lambda (cptr tag) (cpointer-has-tag? cptr tag))])) #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))]))
(define-syntax (cpointer-push-tag! stx) (define-syntax (cpointer-push-tag! stx)
@ -1261,7 +1266,8 @@
;; type. ;; type.
(provide define-cstruct) (provide define-cstruct)
(define-syntax (define-cstruct stx) (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 (define name
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
(define slot-names (map (lambda (x) (symbol->string (syntax-e x))) (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
@ -1286,6 +1292,7 @@
[(slot ...) slot-names-stx] [(slot ...) slot-names-stx]
[(slot-type ...) slot-types-stx] [(slot-type ...) slot-types-stx]
[TYPE (id name)] [TYPE (id name)]
[cpointer:TYPE (id "cpointer:"name)]
[_TYPE _TYPE-stx] [_TYPE _TYPE-stx]
[_TYPE-pointer (id "_"name"-pointer")] [_TYPE-pointer (id "_"name"-pointer")]
[_TYPE-pointer/null (id "_"name"-pointer/null")] [_TYPE-pointer/null (id "_"name"-pointer/null")]
@ -1293,6 +1300,12 @@
[_TYPE* (id "_"name"*")] [_TYPE* (id "_"name"*")]
[TYPE? (id name"?")] [TYPE? (id name"?")]
[make-TYPE (id "make-"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)]
[list*->TYPE (id "list*->"name)] [list*->TYPE (id "list*->"name)]
[TYPE->list (id name"->list")] [TYPE->list (id name"->list")]
@ -1310,7 +1323,24 @@
(safe-id=? 1st-type #'_TYPE-pointer)) (safe-id=? 1st-type #'_TYPE-pointer))
#'(values #f '() #f #f #f #f) #'(values #f '() #f #f #f #f)
#`(cstruct-info #,1st-type #`(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 #'(begin
(define-syntax TYPE (define-syntax TYPE
(make-struct-info (make-struct-info
@ -1328,25 +1358,27 @@
super->list* list*->super) super->list* list*->super)
get-super-info]) get-super-info])
(define-cpointer-type _TYPE super-pointer) (define-cpointer-type _TYPE super-pointer)
;; these makes it possible to use recursive pointer definitions define-wrap-type
(define _TYPE-pointer _TYPE) ;; these make it possible to use recursive pointer definitions
(define _TYPE-pointer/null _TYPE/null) (define _TYPE-pointer (wrap-TYPE-type _TYPE))
(let*-values ([(stype ...) (values slot-type ...)] (define _TYPE-pointer/null (wrap-TYPE-type _TYPE/null))
[(types) (list stype ...)] (define-values (stype ...) (values slot-type ...))
[(alignment-v) alignment] (define types (list stype ...))
[(offsets) (compute-offsets types alignment-v)] (define alignment-v alignment)
[(offset ...) (apply values offsets)]) (define offsets (compute-offsets types alignment-v))
(define-values (offset ...) (apply values offsets))
(define all-tags (cons TYPE-tag super-tags)) (define all-tags (cons TYPE-tag super-tags))
(define _TYPE* (define _TYPE*
;; c->scheme adjusts all tags ;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types #f alignment-v)] (let* ([cst (make-cstruct-type types #f alignment-v)]
[t (_cpointer TYPE-tag cst)] [t (_cpointer TYPE-tag cst)]
[c->s (ctype-c->scheme t)]) [c->s (ctype-c->scheme t)])
(wrap-TYPE-type
(make-ctype cst (ctype-scheme->c t) (make-ctype cst (ctype-scheme->c t)
;; hack: modify & reuse the procedure made by _cpointer ;; hack: modify & reuse the procedure made by _cpointer
(lambda (p) (lambda (p)
(if p (set-cpointer-tag! p all-tags) (c->s p)) (if p (set-cpointer-tag! p all-tags) (c->s p))
p)))) p)))))
(define-values (all-types all-offsets) (define-values (all-types all-offsets)
(if (and has-super? super-types super-offsets) (if (and has-super? super-types super-offsets)
(values (append super-types (cdr types)) (values (append super-types (cdr types))
@ -1367,7 +1399,7 @@
;; init using all slots ;; init using all slots
(lambda vals (lambda vals
(if (= (length vals) (length all-types)) (if (= (length vals) (length all-types))
(let ([block (malloc _TYPE*)]) (let ([block (make-wrap-TYPE (malloc _TYPE*))])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(for-each (lambda (type ofs value) (for-each (lambda (type ofs value)
(ptr-set! block type 'abs ofs value)) (ptr-set! block type 'abs ofs value))
@ -1377,11 +1409,12 @@
(length all-types) (length vals) vals))) (length all-types) (length vals) vals)))
;; normal initializer ;; normal initializer
(lambda (slot ...) (lambda (slot ...)
(let ([block (malloc _TYPE*)]) (let ([block (make-wrap-TYPE (malloc _TYPE*))])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(ptr-set! block stype 'abs offset slot) (ptr-set! block stype 'abs offset slot)
... ...
block)))) block))))
define-wrapper-struct
(define (list->TYPE vals) (apply make-TYPE vals)) (define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals) (define (list*->TYPE vals)
(cond (cond
@ -1424,7 +1457,7 @@
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))) list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
(define (err what . xs) (define (err what . xs)
(apply raise-syntax-error #f (apply raise-syntax-error #f
(if (list? what) (apply string-append what) what) (if (list? what) (apply string-append what) what)
@ -1435,15 +1468,23 @@
(syntax-case #'type () (syntax-case #'type ()
[(t s) (values #'t #'s)] [(t s) (values #'t #'s)]
[_ (values #'type #f)])] [_ (values #'type #f)])]
[(alignment) [(alignment properties)
(syntax-case #'more () (let loop ([more #'more] [alignment #f] [properties null])
[() #'#f] (define (head) (syntax-case more () [(x . _) #'x]))
[(#:alignment) (err "missing expression for #:alignment")] (syntax-case more ()
[(#:alignment a) #'a] [() (values alignment (reverse properties))]
[(#:alignment a x . _) (err "unexpected form" #'x)] [(#: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)) [(x . _) (err (if (keyword? (syntax-e #'x))
"unknown keyword" "unexpected form") "unknown keyword" "unexpected form")
#'x)])]) #'x)]
[else (err "bad syntax")]))])
(unless (identifier? _TYPE) (unless (identifier? _TYPE)
(err "bad type, expecting a _name identifier or (_name super-ctype)" (err "bad type, expecting a _name identifier or (_name super-ctype)"
_TYPE)) _TYPE))
@ -1456,8 +1497,10 @@
(make-syntax _TYPE #t (make-syntax _TYPE #t
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
#`(#,_SUPER slot-type ...) #`(#,_SUPER slot-type ...)
alignment) alignment
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))] properties)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...)
alignment properties)))]
;; specific errors for bad slot specs, leave the rest for a generic error ;; specific errors for bad slot specs, leave the rest for a generic error
[(_ type (bad ...) . more) [(_ type (bad ...) . more)
(err "bad slot specification, expecting [name ctype]" (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 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 be used as a pointer: @racket[#f] (used as a @cpp{NULL} pointer), byte
strings (used as memory blocks), or some additional internal objects strings (used as memory blocks), or a structure instance with the
(@racket[ffi-obj]s and callbacks, see @secref["foreign:c-only"]). @racket[prop:cpointer] @tech[#:doc reference.scrbl]{structure type
Returns @racket[#f] for other values.} property}. Returns @racket[#f] for other values.}
@defproc[(ptr-equal? [cptr1 cpointer?] [cptr2 cpointer?]) boolean?]{ @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 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 string, because the offset pointer would be to the middle of a
collectable object (which is not allowed).} 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.} 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/sup _id
(_id super-id)) (_id super-id))
(alignment code:blank (property (code:line #:alignment alignment-expr)
(code:line #:alignment alignment-expr))]]{ (code:line #:property prop-expr val-expr))]]{
Defines a new C struct type, but unlike @racket[_list-struct], the Defines a new C struct type, but unlike @racket[_list-struct], the
resulting type deals with C structs in binary form, rather than resulting type deals with C structs in binary form, rather than
marshaling them to Racket values. The syntax is similar to marshaling them to Racket values. The syntax is similar to
@racket[define-struct], providing accessor functions for raw struct @racket[define-struct], providing accessor functions for raw struct
values (which are pointer objects). The new type uses pointer tags to values (which are pointer objects); the @racket[_id]
guarantee that only proper struct objects are used. The @racket[_id] must start with @litchar{_}, and at most one @racket[#:alignment]
must start with @litchar{_}. can be supplied.
The resulting bindings are as follows: 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 @item{@racket[_id]@racketidfont{-pointer}: a pointer type that should
be used when a pointer to values of this struct are used.} 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{?}: a predicate for the new type.}
@item{@racketvarfont{id}@racketidfont{-tag}: the tag object that is @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.} symbol and other symbols, such as the @racketvarfont{super-id} symbol.}
@item{@racketidfont{make-}@racketvarfont{id} : a constructor, which expects @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 @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 the result of the accessor is a pointer to the field within the
enclosing structure, rather than a copy of the field.} 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].} : a mutator function for each @racket[field-id].}
@item{@racketvarfont{id}: structure-type information compatible with @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] currently, this information is correct only when no @racket[super-id]
is specified.} is specified.}
@item{@racketvarfont{id}->list : a function that converts a struct into @item{@racketvarfont{id}@racketidfont{->list},
a list of values.} @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 struct to be copied rather than use the pointer value, leading to
memory corruption. 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 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 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 is its super-struct. Instances of the sub-struct can be considered as
instances of the super-struct, since they share the same initial 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 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. example below.
Providing a @racket[super-id] is shorthand for using an initial field 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, addition for the new fields. This adjustment of the constructor is,
again, in analogy to using a supertype with @racket[define-struct]. 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 garbage collector ignores their content. Thus, struct fields can hold
only non-pointer values, pointers to memory outside the GC's control, only non-pointer values, pointers to memory outside the GC's control,
and otherwise-reachable pointers to immobile GC-managed values (such and otherwise-reachable pointers to immobile GC-managed values (such

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

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

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

@ -6,4 +6,5 @@
(load-relative "syntax-tests.rktl") (load-relative "syntax-tests.rktl")
(load-in-sandbox "version.rktl") (load-in-sandbox "version.rktl")
(load-in-sandbox "foreign-test.rktl") (load-in-sandbox "foreign-test.rktl")
(load-in-sandbox "cstruct.rktl")
(load-in-sandbox "uni-norm.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 Version 5.2.1.5
Added racket/future to re-exports of racket Added racket/future to re-exports of racket
Changed current-write-relative-directory to support a pair 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) \ #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)) ((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?" #define MYNAME "cpointer?"
static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) 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 #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[]) static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *tag = NULL; 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); 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; return (tag == NULL) ? scheme_false : tag;
} }
#undef MYNAME #undef MYNAME
@ -1399,9 +1448,11 @@ static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
#define MYNAME "set-cpointer-tag!" #define MYNAME "set-cpointer-tag!"
static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[]) 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_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
SCHEME_CPTR_TYPE(argv[0]) = argv[1]; SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void; return scheme_void;
} }
#undef MYNAME #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)); val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type); type = CTYPE_BASETYPE(type);
} }
val = unwrap_cpointer_property(val);
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers. */ /* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val)) if (SCHEME_FFICALLBACKP(val))
@ -2084,6 +2136,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
void *(*mf)(size_t); void *(*mf)(size_t);
for (i=0; i<argc; i++) { for (i=0; i<argc; i++) {
a = argv[i]; a = argv[i];
a = unwrap_cpointer_property(argv[i]);
if (SCHEME_INTP(a)) { if (SCHEME_INTP(a)) {
if (num != 0) if (num != 0)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a); 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; void *ptr;
intptr_t poff; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]); poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0)) if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_end_stubborn_change(W_OFFSET(ptr, poff)); scheme_end_stubborn_change(W_OFFSET(ptr, poff));
@ -2167,10 +2222,12 @@ static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
{ {
void *ptr; void *ptr;
intptr_t poff; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]); poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0)) if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
free(W_OFFSET(ptr, poff)); free(W_OFFSET(ptr, poff));
@ -2194,10 +2251,12 @@ static Scheme_Object *foreign_free_immobile_cell(int argc, Scheme_Object *argv[]
{ {
void *ptr; void *ptr;
intptr_t poff; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]); poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0)) if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff)); 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) int argc, Scheme_Object **argv)
{ {
intptr_t noff; intptr_t noff;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (is_bang) { 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); scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
} else { } else {
if (!SCHEME_FFIANYPTRP(argv[0])) if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", 0, argc, argv); scheme_wrong_type(who, "cpointer", 0, argc, argv);
} }
if (!scheme_get_int_val(argv[1], &noff)) 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); scheme_wrong_type(who, "C-type", 2, argc, argv);
} }
if (is_bang) { if (is_bang) {
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff; ((Scheme_Offset_Cptr*)(cp))->offset += noff;
return scheme_void; return scheme_void;
} else { } 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 return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]), (SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); (SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
else else
return scheme_make_offset_cptr return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]), (SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); (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?" #define MYNAME "offset-ptr?"
static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[]) 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 #undef MYNAME
@ -2281,9 +2344,11 @@ static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[])
#define MYNAME "ptr-offset" #define MYNAME "ptr-offset"
static Scheme_Object *foreign_ptr_offset(int argc, Scheme_Object *argv[]) 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); 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 #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[]) static Scheme_Object *foreign_set_ptr_offset_bang(int argc, Scheme_Object *argv[])
{ {
intptr_t noff; 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); scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff)) { if (!scheme_get_int_val(argv[1], &noff)) {
scheme_wrong_type(MYNAME, C_INTPTR_T_TYPE_STR, 1, argc, argv); 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 } else
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); 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; return scheme_void;
} }
#undef MYNAME #undef MYNAME
@ -2331,6 +2398,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
void *src = NULL, *dest = NULL; void *src = NULL, *dest = NULL;
intptr_t soff = 0, doff = 0, count, v, mult = 0; intptr_t soff = 0, doff = 0, count, v, mult = 0;
int i, j, ch = 0, argc1 = argc; int i, j, ch = 0, argc1 = argc;
Scheme_Object *cp;
/* arg parsing: last optional ctype, then count, then fill byte for memset, /* arg parsing: last optional ctype, then count, then fill byte for memset,
* then the first and second pointer+offset pair. */ * 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, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: missing a pointer argument for %s", "%s: missing a pointer argument for %s",
who, (j == 0 ? "destination" : "source")); 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); scheme_wrong_type(who, "cpointer", i, argc, argv);
switch (j) { switch (j) {
case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]); case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
doff = SCHEME_FFIANYPTR_OFFSET(argv[i]); doff = SCHEME_FFIANYPTR_OFFSET(cp);
break; break;
case 1: src = SCHEME_FFIANYPTR_VAL(argv[i]); case 1: src = SCHEME_FFIANYPTR_VAL(cp);
soff = SCHEME_FFIANYPTR_OFFSET(argv[i]); soff = SCHEME_FFIANYPTR_OFFSET(cp);
break; break;
} }
i++; i++;
@ -2450,12 +2519,13 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
{ {
int size=0; void *ptr; Scheme_Object *base; int size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1; intptr_t delta; int gcsrc=1;
Scheme_Object *cp;
if (!SCHEME_FFIANYPTRP(argv[0])) cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(cp);
if (!is_gcable_pointer(argv[0])) if (!is_gcable_pointer(cp))
gcsrc = 0; gcsrc = 0;
if ((ptr == NULL) && (delta == 0)) if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); 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); size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (SCHEME_FFIOBJP(argv[0])) { if (SCHEME_FFIOBJP(cp)) {
/* The ffiobj pointer is the function pointer. */ /* The ffiobj pointer is the function pointer. */
ptr = argv[0]; ptr = cp;
delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj); 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; int size=0; void *ptr;
intptr_t delta; intptr_t delta;
Scheme_Object *val = argv[argc-1], *base; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (delta == 0)) if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1]))) 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?" #define MYNAME "ptr-equal?"
static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[]) 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); 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); scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
return (SAME_OBJ(argv[0],argv[1]) || return (SAME_OBJ(cp1, cp2) ||
(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) (SCHEME_FFIANYPTR_OFFSETVAL(cp1)
== SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))) == SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
? scheme_true : scheme_false; ? scheme_true : scheme_false;
} }
#undef MYNAME #undef MYNAME
@ -2565,13 +2640,15 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar
* pointer. * pointer.
* (Should use real byte-strings with new version.) */ * (Should use real byte-strings with new version.) */
intptr_t len; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1],&len)) if (!scheme_get_int_val(argv[1],&len))
scheme_wrong_type(MYNAME, "integer in a C intptr_t range", 1, argc, argv); 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 else return
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
len, 0); len, 0);
} }
#undef MYNAME #undef MYNAME
@ -2612,16 +2689,18 @@ void do_ptr_finalizer(void *p, void *finalizer)
* cdefine[register-finalizer 2 3]{ * cdefine[register-finalizer 2 3]{
* void *ptr, *old = NULL; * void *ptr, *old = NULL;
* int ptrsym = (argc == 3 && argv[2] == pointer_sym); * int ptrsym = (argc == 3 && argv[2] == pointer_sym);
* Scheme_Object *cp;
* cp = unwrap_cpointer_property(argv[0]);
* if (ptrsym) { * if (ptrsym) {
* if (!SCHEME_FFIANYPTRP(argv[0])) * if (!SCHEME_FFIANYPTRP(cp))
* scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); * scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
* ptr = SCHEME_FFIANYPTR_VAL(argv[0]); * ptr = SCHEME_FFIANYPTR_VAL(cp);
* if (ptr == NULL) * if (ptr == NULL)
* scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); * scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
* } else { * } else {
* if (argc == 3) * if (argc == 3)
* scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); * scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
* ptr = argv[0]; * ptr = cp;
* } * }
* if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) * if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
* scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); * 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 *itypes = argv[1];
Scheme_Object *otype = argv[2]; Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base; Scheme_Object *obj, *data, *p, *base, *cp;
ffi_abi abi; ffi_abi abi;
intptr_t ooff; intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_type *rtype, **atypes;
@ -2834,10 +2913,11 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
#else #else
# define FFI_CALL_VEC_SIZE 7 # define FFI_CALL_VEC_SIZE 7
#endif #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); scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
obj = SCHEME_FFIANYPTR_VAL(argv[0]); obj = SCHEME_FFIANYPTR_VAL(cp);
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]); ooff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((obj == NULL) && (ooff == 0)) if ((obj == NULL) && (ooff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
nargs = scheme_proper_list_length(itypes); 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 p = scheme_append_byte_string
(ffi_name_prefix, (ffi_name_prefix,
scheme_make_byte_string_without_copying scheme_make_byte_string_without_copying
(SCHEME_FFIOBJP(argv[0]) ? (SCHEME_FFIOBJP(cp) ?
((ffi_obj_struct*)(argv[0]))->name : "proc")); ((ffi_obj_struct*)(cp))->name : "proc"));
SCHEME_VEC_ELS(data)[0] = p; SCHEME_VEC_ELS(data)[0] = p;
SCHEME_VEC_ELS(data)[1] = obj; SCHEME_VEC_ELS(data)[1] = obj;
SCHEME_VEC_ELS(data)[2] = itypes; 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->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
scheme_add_global("_fpointer", (Scheme_Object*)t, menv); scheme_add_global("_fpointer", (Scheme_Object*)t, menv);
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv); scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL); scheme_protect_primitive_provide(menv, NULL);
} }
@ -3727,6 +3808,15 @@ void scheme_init_foreign(Scheme_Env *env)
#else /* DONT_USE_FOREIGN */ #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) static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who)
{ {
scheme_signal_error("%s: foreign interface not supported for this platform", 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("_gcpointer", scheme_false, menv);
scheme_add_global("_scheme", scheme_false, menv); scheme_add_global("_scheme", scheme_false, menv);
scheme_add_global("_fpointer", 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_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL); 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) \ #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)) ((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]{ @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]{ @cdefine[cpointer-tag 1]{
Scheme_Object *tag = NULL; 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); 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; return (tag == NULL) ? scheme_false : tag;
} }
@cdefine[set-cpointer-tag! 2]{ @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_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
SCHEME_CPTR_TYPE(argv[0]) = argv[1]; SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void; 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)); val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type); type = CTYPE_BASETYPE(type);
} }
val = unwrap_cpointer_property(val);
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers. */ /* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val)) if (SCHEME_FFICALLBACKP(val))
@ -1502,6 +1554,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
void *(*mf)(size_t); void *(*mf)(size_t);
for (i=0; i<argc; i++) { for (i=0; i<argc; i++) {
a = argv[i]; a = argv[i];
a = unwrap_cpointer_property(argv[i]);
if (SCHEME_INTP(a)) { if (SCHEME_INTP(a)) {
if (num != 0) if (num != 0)
scheme_signal_error(MYNAME": specifying a second integer size: %V", a); 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]{ @cdefine[end-stubborn-change 1]{
void *ptr; void *ptr;
intptr_t poff; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]); poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0)) if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_end_stubborn_change(W_OFFSET(ptr, poff)); 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]{ @cdefine[free 1]{
void *ptr; void *ptr;
intptr_t poff; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]); poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0)) if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
free(W_OFFSET(ptr, poff)); 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]{ @cdefine[free-immobile-cell 1]{
void *ptr; void *ptr;
intptr_t poff; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]); poff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (poff == 0)) if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff)); 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) int argc, Scheme_Object **argv)
{ {
intptr_t noff; intptr_t noff;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (is_bang) { 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); scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
} else { } else {
if (!SCHEME_FFIANYPTRP(argv[0])) if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(who, "cpointer", 0, argc, argv); scheme_wrong_type(who, "cpointer", 0, argc, argv);
} }
if (!scheme_get_int_val(argv[1], &noff)) 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); scheme_wrong_type(who, "C-type", 2, argc, argv);
} }
if (is_bang) { if (is_bang) {
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff; ((Scheme_Offset_Cptr*)(cp))->offset += noff;
return scheme_void; return scheme_void;
} else { } 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 return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]), (SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); (SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
else else
return scheme_make_offset_cptr return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]), (SCHEME_FFIANYPTR_VAL(cp),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, SCHEME_FFIANYPTR_OFFSET(cp) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); (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) */ /* (offset-ptr? x) */
/* Returns #t if the argument is a cpointer with an offset */ /* Returns #t if the argument is a cpointer with an offset */
@cdefine[offset-ptr? 1 1]{ @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) */ /* (ptr-offset ptr) */
/* Returns the offset of a cpointer (0 if it's not an offset pointer) */ /* Returns the offset of a cpointer (0 if it's not an offset pointer) */
@cdefine[ptr-offset 1 1]{ @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); 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]) */ /* (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) */ * the given ctype) */
@cdefine[set-ptr-offset! 2 3]{ @cdefine[set-ptr-offset! 2 3]{
intptr_t noff; 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); scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1], &noff)) { if (!scheme_get_int_val(argv[1], &noff)) {
scheme_wrong_type(MYNAME, C_INTPTR_T_TYPE_STR, 1, argc, argv); 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 } else
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); 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; return scheme_void;
} }
@ -1717,6 +1784,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
void *src = NULL, *dest = NULL; void *src = NULL, *dest = NULL;
intptr_t soff = 0, doff = 0, count, v, mult = 0; intptr_t soff = 0, doff = 0, count, v, mult = 0;
int i, j, ch = 0, argc1 = argc; int i, j, ch = 0, argc1 = argc;
Scheme_Object *cp;
/* arg parsing: last optional ctype, then count, then fill byte for memset, /* arg parsing: last optional ctype, then count, then fill byte for memset,
* then the first and second pointer+offset pair. */ * 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, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: missing a pointer argument for %s", "%s: missing a pointer argument for %s",
who, (j == 0 ? "destination" : "source")); 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); scheme_wrong_type(who, "cpointer", i, argc, argv);
switch (j) { switch (j) {
case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]); case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
doff = SCHEME_FFIANYPTR_OFFSET(argv[i]); doff = SCHEME_FFIANYPTR_OFFSET(cp);
break; break;
case 1: src = SCHEME_FFIANYPTR_VAL(argv[i]); case 1: src = SCHEME_FFIANYPTR_VAL(cp);
soff = SCHEME_FFIANYPTR_OFFSET(argv[i]); soff = SCHEME_FFIANYPTR_OFFSET(cp);
break; break;
} }
i++; i++;
@ -1813,12 +1882,13 @@ static Scheme_Object *do_memop(const char *who, int mode,
@cdefine[ptr-ref 2 4]{ @cdefine[ptr-ref 2 4]{
int size=0; void *ptr; Scheme_Object *base; int size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1; intptr_t delta; int gcsrc=1;
Scheme_Object *cp;
if (!SCHEME_FFIANYPTRP(argv[0])) cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(cp);
if (!is_gcable_pointer(argv[0])) if (!is_gcable_pointer(cp))
gcsrc = 0; gcsrc = 0;
if ((ptr == NULL) && (delta == 0)) if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); 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); size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (SCHEME_FFIOBJP(argv[0])) { if (SCHEME_FFIOBJP(cp)) {
/* The ffiobj pointer is the function pointer. */ /* The ffiobj pointer is the function pointer. */
ptr = argv[0]; ptr = cp;
delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj); 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; int size=0; void *ptr;
intptr_t delta; intptr_t delta;
Scheme_Object *val = argv[argc-1], *base; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(cp);
if ((ptr == NULL) && (delta == 0)) if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1]))) 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 */ /* (ptr-equal? cpointer cpointer) -> boolean */
@cdefine[ptr-equal? 2 2]{ @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); 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); scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
return (SAME_OBJ(argv[0],argv[1]) || return (SAME_OBJ(cp1, cp2) ||
(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) (SCHEME_FFIANYPTR_OFFSETVAL(cp1)
== SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))) == SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
? scheme_true : scheme_false; ? scheme_true : scheme_false;
} }
@ -1919,13 +1994,15 @@ static Scheme_Object *do_memop(const char *who, int mode,
* pointer. * pointer.
* (Should use real byte-strings with new version.) */ * (Should use real byte-strings with new version.) */
intptr_t len; 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); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
if (!scheme_get_int_val(argv[1],&len)) if (!scheme_get_int_val(argv[1],&len))
scheme_wrong_type(MYNAME, "integer in a C intptr_t range", 1, argc, argv); 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 else return
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
len, 0); len, 0);
} }
@ -1966,16 +2043,18 @@ defsymbols[pointer]
cdefine[register-finalizer 2 3]{ cdefine[register-finalizer 2 3]{
void *ptr, *old = NULL; void *ptr, *old = NULL;
int ptrsym = (argc == 3 && argv[2] == pointer_sym); int ptrsym = (argc == 3 && argv[2] == pointer_sym);
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (ptrsym) { if (ptrsym) {
if (!SCHEME_FFIANYPTRP(argv[0])) if (!SCHEME_FFIANYPTRP(cp))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(cp);
if (ptr == NULL) if (ptr == NULL)
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
} else { } else {
if (argc == 3) if (argc == 3)
scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
ptr = argv[0]; ptr = cp;
} }
if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); 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]{ @cdefine[ffi-call 3 6]{
Scheme_Object *itypes = argv[1]; Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2]; Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base; Scheme_Object *obj, *data, *p, *base, *cp;
ffi_abi abi; ffi_abi abi;
intptr_t ooff; intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_type *rtype, **atypes;
@ -2186,10 +2265,11 @@ static Scheme_Object *ffi_name_prefix = NULL;
#else #else
# define FFI_CALL_VEC_SIZE 7 # define FFI_CALL_VEC_SIZE 7
#endif #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); scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
obj = SCHEME_FFIANYPTR_VAL(argv[0]); obj = SCHEME_FFIANYPTR_VAL(cp);
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]); ooff = SCHEME_FFIANYPTR_OFFSET(cp);
if ((obj == NULL) && (ooff == 0)) if ((obj == NULL) && (ooff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
nargs = scheme_proper_list_length(itypes); nargs = scheme_proper_list_length(itypes);
@ -2236,8 +2316,8 @@ static Scheme_Object *ffi_name_prefix = NULL;
p = scheme_append_byte_string p = scheme_append_byte_string
(ffi_name_prefix, (ffi_name_prefix,
scheme_make_byte_string_without_copying scheme_make_byte_string_without_copying
(SCHEME_FFIOBJP(argv[0]) ? (SCHEME_FFIOBJP(cp) ?
((ffi_obj_struct*)(argv[0]))->name : "proc")); ((ffi_obj_struct*)(cp))->name : "proc"));
SCHEME_VEC_ELS(data)[0] = p; SCHEME_VEC_ELS(data)[0] = p;
SCHEME_VEC_ELS(data)[1] = obj; SCHEME_VEC_ELS(data)[1] = obj;
SCHEME_VEC_ELS(data)[2] = itypes; 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*)(void*)(&ffi_type_@ftype)}
@list{(Scheme_Object*)FOREIGN_@cname}] @list{(Scheme_Object*)FOREIGN_@cname}]
scheme_add_global("_@stype", (Scheme_Object*)t, menv)}) scheme_add_global("_@stype", (Scheme_Object*)t, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv); scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL); scheme_protect_primitive_provide(menv, NULL);
} }
@ -2777,6 +2858,15 @@ void scheme_init_foreign(Scheme_Env *env)
#else /* DONT_USE_FOREIGN */ #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) static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who)
{ {
scheme_signal_error("%s: foreign interface not supported for this platform", scheme_signal_error("%s: foreign interface not supported for this platform",
@ -2819,6 +2909,7 @@ void scheme_init_foreign(Scheme_Env *env)
(reverse (cfunctions))) (reverse (cfunctions)))
@(map-types @(map-types
@list{scheme_add_global("_@stype", scheme_false, menv)}) @list{scheme_add_global("_@stype", scheme_false, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv); scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL); 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_offset_cptr
scheme_make_external_cptr scheme_make_external_cptr
scheme_make_offset_external_cptr scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name scheme_get_proc_name
scheme_utf8_decode scheme_utf8_decode
scheme_utf8_decode_as_prefix scheme_utf8_decode_as_prefix

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

@ -333,6 +333,7 @@ EXPORTS
scheme_make_offset_cptr scheme_make_offset_cptr
scheme_make_external_cptr scheme_make_external_cptr
scheme_make_offset_external_cptr scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name scheme_get_proc_name
scheme_utf8_decode scheme_utf8_decode
scheme_utf8_decode_as_prefix 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_offset_cptr
scheme_make_external_cptr scheme_make_external_cptr
scheme_make_offset_external_cptr scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name scheme_get_proc_name
scheme_utf8_decode scheme_utf8_decode
scheme_utf8_decode_as_prefix 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_offset_cptr
scheme_make_external_cptr scheme_make_external_cptr
scheme_make_offset_external_cptr scheme_make_offset_external_cptr
scheme_is_cpointer
scheme_get_proc_name scheme_get_proc_name
scheme_utf8_decode scheme_utf8_decode
scheme_utf8_decode_as_prefix 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_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 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); 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_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_external_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_external_cptr)(void *cptr, intptr_t offset, 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); const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
/*========================================================================*/ /*========================================================================*/
/* strings */ /* 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_offset_cptr = scheme_make_offset_cptr;
scheme_extension_table->scheme_make_external_cptr = scheme_make_external_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_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_get_proc_name = scheme_get_proc_name;
scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode; scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode;
scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix; 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_offset_cptr (scheme_extension_table->scheme_make_offset_cptr)
#define scheme_make_external_cptr (scheme_extension_table->scheme_make_external_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_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_get_proc_name (scheme_extension_table->scheme_get_proc_name)
#define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode) #define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode)
#define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix) #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); 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_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_cpointer_property;
extern Scheme_Object *scheme_equal_property; extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_impersonator_of_property; extern Scheme_Object *scheme_impersonator_of_property;

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.2.1.5" #define MZSCHEME_VERSION "5.2.1.6"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 1 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

113
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_source_property;
READ_ONLY Scheme_Object *scheme_input_port_property; READ_ONLY Scheme_Object *scheme_input_port_property;
READ_ONLY Scheme_Object *scheme_output_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_equal_property;
READ_ONLY Scheme_Object *scheme_no_arity_property; READ_ONLY Scheme_Object *scheme_no_arity_property;
READ_ONLY Scheme_Object *scheme_impersonator_of_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_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_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_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_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_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_checked_proc_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); 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); REGISTER_SO(rename_transformer_property);
@ -1331,25 +1343,26 @@ static int extract_accessor_offset(Scheme_Object *acc)
return 0; return 0;
} }
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]) typedef int (*Check_Val_Proc)(Scheme_Object *);
/* This is the guard for prop:evt */
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; Scheme_Object *v, *l, *acc;
int pos, num_islots; int pos, num_islots;
v = argv[0]; v = argv[0];
if (scheme_is_evt(v)) if (ck(v))
return 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; return v;
if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0)) if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v)))) || (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
scheme_arg_mismatch("guard-for-prop:evt", scheme_arg_mismatch(name, complain, v);
"property value is not a evt, procedure (arity 1), or exact non-negative integer: ",
v);
l = argv[1]; l = argv[1];
l = SCHEME_CDR(l); l = SCHEME_CDR(l);
@ -1367,7 +1380,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
pos = SCHEME_INT_VAL(v); pos = SCHEME_INT_VAL(v);
if (pos >= num_islots) { if (pos >= num_islots) {
scheme_arg_mismatch("guard-for-prop:evt", scheme_arg_mismatch(name,
"field index >= initialized-field count for structure type: ", "field index >= initialized-field count for structure type: ",
v); v);
} }
@ -1378,7 +1391,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
} }
if (!SCHEME_PAIRP(l)) { if (!SCHEME_PAIRP(l)) {
scheme_arg_mismatch("guard-for-prop:evt", scheme_arg_mismatch(name,
"field index not declared immutable: ", "field index not declared immutable: ",
v); v);
} }
@ -1389,6 +1402,15 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
return v; 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[]) static Scheme_Object *return_wrapped(void *data, int argc, Scheme_Object *argv[])
{ {
return (Scheme_Object *)data; return (Scheme_Object *)data;
@ -1468,61 +1490,6 @@ static int is_evt_struct(Scheme_Object *o)
/* port structs */ /* 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_input_port(Scheme_Object *v) { return SCHEME_INPUT_PORTP(v); }
static int is_output_port(Scheme_Object *v) { return SCHEME_OUTPUT_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 */ /* This is the guard for prop:input-port and prop:output-port */
{ {
return check_indirect_property_value_ok(name, return check_indirect_property_value_ok(name,
input ? is_input_port : is_output_port, input ? is_input_port : is_output_port, 0,
(input (input
? "property value is not an input port or exact non-negative integer: " ? "property value is not an input port or exact non-negative integer: "
: "property value is not an output 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); 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 */ /* 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[]) 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", 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: ", "property value is not an identifier or exact non-negative integer, optionaly boxed: ",
argc, argv); 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[]) 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", 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: ", "property value is not an procedure (arity 1 or 2) or exact non-negative integer: ",
argc, argv); argc, argv);
} }