ffi/unsafe: allow multiple values for a `(_fun ... -> _racket)' result

Closes PR 13496
This commit is contained in:
Matthew Flatt 2013-02-14 15:43:36 -07:00
parent 421cb24138
commit 3cd4ee1c0d
3 changed files with 36 additions and 16 deletions

View File

@ -522,7 +522,7 @@
(define ((t-n-e clause) type name expr)
(let ([keys (custom-type->keys type err)])
(define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
(define (arg x . no-expr?)
(define (arg x . no-expr?) ;; can mutate `name'
(define use-expr?
(and (list? x) (= 2 (length x)) (identifier? (car x))))
;; when the current expr is not used with a (x => ...) form,
@ -533,7 +533,9 @@
(err "got an expression for a custom type that do not use it"
clause)
(set! expr (void))))
(when use-expr? (set! x (with-renamer (car x) name (cadr x))))
(when use-expr?
(unless name (set! name (car (generate-temporaries #'(ret)))))
(set! x (with-renamer (car x) name (cadr x))))
(cond [(getkey '1st) =>
(lambda (v)
(if 1st-arg
@ -551,8 +553,10 @@
(set! type (getkey 'type))
(cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
(cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))])
(cond [(getkey 'pre ) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))])
(cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])
(cond [(getkey 'pre ) => (lambda (x) (pre! (let ([a (arg x #t)])
#`[#,name #,a])))])
(cond [(getkey 'post) => (lambda (x) (post! (let ([a (arg x)])
#`[#,name #,a])))])
(cond [(getkey 'keywords)
=> (lambda (ks)
(for ([k+v (in-list ks)])
@ -615,18 +619,17 @@
;; when processing the output type, only the post code matters
(set! pre! (lambda (x) #f))
(set! output
(let ([temp (car (generate-temporaries #'(ret)))]
[t-n-e (t-n-e output-type)])
(let ([t-n-e (t-n-e output-type)])
(syntax-case* output-type (: =) id=?
[(name : type) (t-n-e #'type #'name output-expr)]
[(type = expr) (if output-expr
(err "extraneous output expression" #'expr)
(t-n-e #'type temp #'expr))]
(t-n-e #'type #f #'expr))]
[(name : type = expr)
(if output-expr
(err "extraneous output expression" #'expr)
(t-n-e #'type #'name #'expr))]
[type (t-n-e #'type temp output-expr)])))
[type (t-n-e #'type #f output-expr)])))
(let ([make-cprocedure
(lambda (wrapper)
#`(_cprocedure* (list #,@(filter-map car inputs))
@ -647,7 +650,7 @@
inputs))]
[output-expr
(let ([o (caddr output)])
(or (and (not (void? o)) o) (cadr output)))]
(and (not (void? o)) o))]
[args
(filter-map (lambda (i)
(and (caddr i)
@ -661,10 +664,17 @@
(lambda #,input-names
(let* (#,@args
#,@bind
#,@pre
[#,(cadr output) (ffi #,@ffi-args)]
#,@post)
#,output-expr)))]
#,@pre)
#,(if (or output-expr
(cadr output))
(let ([res (or (cadr output)
(car (generate-temporaries #'(ret))))])
#`(let* ([#,res (ffi #,@ffi-args)]
#,@post)
#,(or output-expr res)))
#`(begin0
(ffi #,@ffi-args)
#,@post)))))]
;; if there is a string 'ffi-name property, use it as a name
[body (let ([n (cond [(syntax-property stx 'ffi-name)
=> syntax->datum]

View File

@ -356,9 +356,15 @@ generates @racket[#f] for a cpointer generated via the
)]{
A type that can be used with any Racket object; it corresponds to the
@cpp{Scheme_Object*} type of Racket's C API (see
@|InsideRacket|). It is useful only for libraries that are aware of
Racket's C API.}
@cpp{Scheme_Object*} type of Racket's C API (see @|InsideRacket|). The
@racket[_racket] or @racket[_scheme] type is useful only for libraries
that are aware of Racket's C API.
As a result type with a function type, @racket[_racket] or
@racket[_scheme] permits multiple values, but multiple values are not
allowed in combination with a true value for
@racket[#:in-original-place?] or @racket[#:async-apply] in
@racket[_cprocedure] or @racket[_fun].}
@defthing[_fpointer ctype?]{

View File

@ -477,6 +477,10 @@
(delete-test-files)
(let ()
(define _values (get-ffi-obj 'scheme_values #f (_fun _int (_list i _racket) -> _racket)))
(test-values '(1 "b" three) (lambda () (_values 3 (list 1 "b" 'three)))))
(report-errs)
#| --- ignore everything below ---