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

make _cpointer types return the result of the scheme->c function, if any

Browse Source 
svn: r11888

original commit: c8be2b6f577700b33d5e5fa8c690c526cdfe022e
This commit is contained in:
Eli Barzilay 2008-09-27 06:35:08 +00:00
parent 616f992c6a
commit 84f2904bb4
1 changed files with 30 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/mzlib/foreign.ss
View File

@ -1176,40 +1176,36 @@
[error-str (format "~a`~a' pointer" [error-str (format "~a`~a' pointer"
(if nullable? "" "non-null ") tag)] (if nullable? "" "non-null ") tag)]
[error* (lambda (p) (raise-type-error tag->C error-str p))]) [error* (lambda (p) (raise-type-error tag->C error-str p))])
(let-syntax ([tag-or-error (define-syntax-rule (tag-or-error ptr t)
(syntax-rules () (let ([p ptr])
[(tag-or-error ptr t) (if (cpointer? p)
(let ([p ptr]) (if (cpointer-has-tag? p t) p (error* p))
(if (cpointer? p) (error* p))))
(unless (cpointer-has-tag? p t) (error* p)) (define-syntax-rule (tag-or-error/null ptr t)
(error* p)))])] (let ([p ptr])
[tag-or-error/null (if (cpointer? p)
(syntax-rules () (and p (if (cpointer-has-tag? p t) p (error* p)))
[(tag-or-error/null ptr t) (error* p))))
(let ([p ptr]) (make-ctype (or ptr-type _pointer)
(if (cpointer? p) ;; bad hack: `if's outside the lambda for efficiency
(when p (unless (cpointer-has-tag? p t) (error* p))) (if nullable?
(error* p)))])]) (if scheme->c
(make-ctype (or ptr-type _pointer) (lambda (p) (tag-or-error/null (scheme->c p) tag))
;; bad hack: `if's outside the lambda for efficiency (lambda (p) (tag-or-error/null p tag)))
(if nullable? (if scheme->c
(if scheme->c (lambda (p) (tag-or-error (scheme->c p) tag))
(lambda (p) (tag-or-error/null (scheme->c p) tag) p) (lambda (p) (tag-or-error p tag))))
(lambda (p) (tag-or-error/null p tag) p)) (if nullable?
(if scheme->c (if c->scheme
(lambda (p) (tag-or-error (scheme->c p) tag) p) (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
(lambda (p) (tag-or-error p tag) p))) (lambda (p) (when p (cpointer-push-tag! p tag)) p))
(if nullable? (if c->scheme
(if c->scheme (lambda (p)
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) (if p (cpointer-push-tag! p tag) (error* p))
(lambda (p) (when p (cpointer-push-tag! p tag)) p)) (c->scheme p))
(if c->scheme (lambda (p)
(lambda (p) (if p (cpointer-push-tag! p tag) (error* p))
(if p (cpointer-push-tag! p tag) (error* p)) p)))))]))
(c->scheme p))
(lambda (p)
(if p (cpointer-push-tag! p tag) (error* p))
p))))))]))
;; This is a kind of a pointer that gets a specific tag when converted to ;; This is a kind of a pointer that gets a specific tag when converted to
;; Scheme, and accepts only such tagged pointers when going to C. An optional ;; Scheme, and accepts only such tagged pointers when going to C. An optional