suzanne.soy/racket
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
This commit is contained in:
Eli Barzilay 2008-09-27 06:35:08 +00:00
parent 856fb22152
commit c8be2b6f57
1 changed files with 30 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mzlib/foreign.ss
View File

@ -1176,29 +1176,25 @@
[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 ()
[(tag-or-error ptr t)
(let ([p ptr]) (let ([p ptr])
(if (cpointer? p) (if (cpointer? p)
(unless (cpointer-has-tag? p t) (error* p)) (if (cpointer-has-tag? p t) p (error* p))
(error* p)))])] (error* p))))
[tag-or-error/null (define-syntax-rule (tag-or-error/null ptr t)
(syntax-rules ()
[(tag-or-error/null ptr t)
(let ([p ptr]) (let ([p ptr])
(if (cpointer? p) (if (cpointer? p)
(when p (unless (cpointer-has-tag? p t) (error* p))) (and p (if (cpointer-has-tag? p t) p (error* p)))
(error* p)))])]) (error* p))))
(make-ctype (or ptr-type _pointer) (make-ctype (or ptr-type _pointer)
;; bad hack: `if's outside the lambda for efficiency ;; bad hack: `if's outside the lambda for efficiency
(if nullable? (if nullable?
(if scheme->c (if scheme->c
(lambda (p) (tag-or-error/null (scheme->c p) tag) p) (lambda (p) (tag-or-error/null (scheme->c p) tag))
(lambda (p) (tag-or-error/null p tag) p)) (lambda (p) (tag-or-error/null p tag)))
(if scheme->c (if scheme->c
(lambda (p) (tag-or-error (scheme->c p) tag) p) (lambda (p) (tag-or-error (scheme->c p) tag))
(lambda (p) (tag-or-error p tag) p))) (lambda (p) (tag-or-error p tag))))
(if nullable? (if nullable?
(if c->scheme (if c->scheme
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
@ -1209,7 +1205,7 @@
(c->scheme p)) (c->scheme p))
(lambda (p) (lambda (p)
(if p (cpointer-push-tag! p tag) (error* p)) (if p (cpointer-push-tag! p tag) (error* p))
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