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

Raise error message if _fun is used incorrectly.

Browse Source 
Closes PR 11323.
This commit is contained in:
Eric Dobson 2015-03-16 20:41:10 -07:00 committed by Matthew Flatt
parent 408d86f1c7
commit cb67ea3edf
2 changed files with 13 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -151,6 +151,9 @@
;; Make sure `_box` at least compiles: ;; Make sure `_box` at least compiles:
(test #t ctype? (_fun (_box _int) -> _void)) (test #t ctype? (_fun (_box _int) -> _void))
;; Check error message on bad _fun form
(syntax-test #'(_fun (b) :: _bool -> _void) #rx"unnamed argument .without an expression. is not allowed")
(define-cstruct _ic7i ([i1 _int] (define-cstruct _ic7i ([i1 _int]
[c7 _c7_list] [c7 _c7_list]
[i2 _int])) [i2 _int]))

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

@ -528,7 +528,7 @@
sub)] sub)]
[(assq k _fun-keywords) (set! ks (cons (cons k v) ks))] [(assq k _fun-keywords) (set! ks (cons (cons k v) ks))]
[else (err "unknown keyword" sub)])))))) [else (err "unknown keyword" sub)]))))))
(define ((t-n-e clause) type name expr) (define ((t-n-e clause) type name expr #:name-ok? [name-ok? #t])
(let ([keys (custom-type->keys type err)]) (let ([keys (custom-type->keys type err)])
(define (getkey key) (cond [(assq key keys) => cdr] [else #f])) (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
(define (arg x . no-expr?) ;; can mutate `name' (define (arg x . no-expr?) ;; can mutate `name'
@ -558,6 +558,14 @@
(err "got a custom type that wants prev arg too early" (err "got a custom type that wants prev arg too early"
clause)))]) clause)))])
x) x)
(unless (or name-ok?
expr
(and keys (or (getkey 'expr)
(getkey 'pre))))
(err (string-append
"unnamed argument (without an expression) is not allowed when "
"argument names are provided before `::'")
clause))
(when keys (when keys
(set! type (getkey 'type)) (set! type (getkey 'type))
(cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))]) (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
@ -622,7 +630,7 @@
[(name : type) (t-n-e #'type #'name #f)] [(name : type) (t-n-e #'type #'name #f)]
[(type = expr) (t-n-e #'type temp #'expr)] [(type = expr) (t-n-e #'type temp #'expr)]
[(name : type = expr) (t-n-e #'type #'name #'expr)] [(name : type = expr) (t-n-e #'type #'name #'expr)]
[type (t-n-e #'type temp #f)]))) [type (t-n-e #'type temp #f #:name-ok? (not input-names))])))
inputs inputs
(generate-temporaries (map (lambda (x) 'tmp) inputs)))) (generate-temporaries (map (lambda (x) 'tmp) inputs))))
;; when processing the output type, only the post code matters ;; when processing the output type, only the post code matters