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

Fix cpointer tags

Browse Source
This commit is contained in:
Jay McCarthy 2016-01-06 19:07:33 -05:00
parent ccc50ca68f
commit d3c09ead19
2 changed files with 13 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -171,6 +171,11 @@
[c7 _c7_list]
[i2 _int]))
(let ()
(define-cstruct _posn ([x _int]
[y _int]))
(test #t equal? 'posn posn-tag))
(define _borl (_union _byte _long))
(define _ic7iorl (_union _ic7i _long))

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

@ -1334,9 +1334,12 @@
(provide define-cpointer-type)
(define-syntax (define-cpointer-type stx)
(syntax-case stx ()
[(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)]
[(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)]
[(_ _TYPE ptr-type scheme->c c->scheme)
[(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f #:tag #f)]
[(_ _TYPE #:tag the-tag) #'(define-cpointer-type _TYPE #f #f #f #:tag the-tag)]
[(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f #:tag #f)]
[(_ _TYPE ptr-type #:tag the-tag) #'(define-cpointer-type _TYPE ptr-type #f #f #:tag the-tag)]
[(_ _TYPE ptr-type scheme->c c->scheme) #'(define-cpointer-type _TYPE ptr-type #f #f #:tag #f)]
[(_ _TYPE ptr-type scheme->c c->scheme #:tag the-tag)
(and (identifier? #'_TYPE)
(regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE))))
(let ([name (cadr (regexp-match #rx"^_(.+)$"
@ -1349,8 +1352,7 @@
[TYPE-tag (id name "-tag")]
[_TYPE/null (id "_" name "/null")])
#'(begin
(define TYPE-tag
(gensym 'TYPE))
(define TYPE-tag (or the-tag 'TYPE))
(define _TYPE
(_cpointer TYPE-tag ptr-type scheme->c c->scheme))
(define _TYPE/null
@ -1552,7 +1554,7 @@
struct:cpointer:super super-wrap-type-type)
get-super-info)
(define-values (property-binding-ids ...) . property-binding-form) ...
(define-cpointer-type _^TYPE super-pointer)
(define-cpointer-type _^TYPE super-pointer #:tag 'TYPE)
define-wrap-type
;; these make it possible to use recursive pointer definitions
(define _TYPE-pointer (wrap-TYPE-type _^TYPE))