From 6cd2e3c71bbee7b1032bcb43207ce8bc57b558fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Feb 2012 14:22:56 -0700 Subject: [PATCH] add `prop:cpointer' 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'. --- collects/ffi/unsafe.rkt | 267 ++++++++++++-------- collects/scribblings/foreign/pointers.scrbl | 25 +- collects/scribblings/foreign/types.scrbl | 50 ++-- collects/scribblings/foreign/utils.rkt | 4 + collects/tests/racket/all.rktl | 1 + collects/tests/racket/cstruct.rktl | 76 ++++++ doc/release-notes/racket/HISTORY.txt | 3 + src/foreign/foreign.c | 213 +++++++++++----- src/foreign/foreign.rktc | 213 +++++++++++----- src/racket/include/mzwin.def | 1 + src/racket/include/mzwin3m.def | 1 + src/racket/include/racket.exp | 1 + src/racket/include/racket3m.exp | 1 + src/racket/src/schemef.h | 2 + src/racket/src/schemex.h | 1 + src/racket/src/schemex.inc | 1 + src/racket/src/schemexm.h | 1 + src/racket/src/schpriv.h | 1 + src/racket/src/schvers.h | 4 +- src/racket/src/struct.c | 117 ++++----- 20 files changed, 660 insertions(+), 323 deletions(-) create mode 100644 collects/tests/racket/cstruct.rktl diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 7fcfda9076..669eaffabc 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -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]" diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 5fa4f1f2b5..dfa21e687f 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -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.} diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index d8647a2019..9ea720e7bf 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -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 diff --git a/collects/scribblings/foreign/utils.rkt b/collects/scribblings/foreign/utils.rkt index 4c1776889b..858f8985cc 100644 --- a/collects/scribblings/foreign/utils.rkt +++ b/collects/scribblings/foreign/utils.rkt @@ -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) diff --git a/collects/tests/racket/all.rktl b/collects/tests/racket/all.rktl index f006abd912..19f86f4884 100644 --- a/collects/tests/racket/all.rktl +++ b/collects/tests/racket/all.rktl @@ -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") diff --git a/collects/tests/racket/cstruct.rktl b/collects/tests/racket/cstruct.rktl new file mode 100644 index 0000000000..f5eb8a9046 --- /dev/null +++ b/collects/tests/racket/cstruct.rktl @@ -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) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 91882e232e..a457285644 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -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 diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 8d06284858..4b3723d167 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -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; ioffset += 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); } diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index def50c5c4f..aae06aef06 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -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; ioffset += 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); } diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index a5f5bd34a9..ad7657e6ad 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -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 diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index b8f240864e..c2812a4a7e 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -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 diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 86081229a6..bb9dcf6fbd 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -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 diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 13c402b876..947728d304 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -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 diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 48b37856d2..c3ad40c646 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -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); /*========================================================================*/ diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index 129931ea97..033f9c058b 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -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 */ diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index 82167709fa..8faa0f4a59 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -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; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index f26f22fb6b..7f3601015d 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -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) diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 26ec942297..50623c94a7 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -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; diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 514dbd9b23..9d8f24cb3c 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -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) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 9871da86e4..7602d4188c 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -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); }