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

Add more error checking to _enum.

Browse Source 
This also fixes some tests which were not running.
This commit is contained in:
Eric Dobson 2015-03-17 23:13:04 -07:00 committed by Matthew Flatt
parent 9fd9a42c61
commit ad899173b9
2 changed files with 35 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -134,25 +134,35 @@
(test 21 ctype-sizeof (_array _byte 3 7)) (test 21 ctype-sizeof (_array _byte 3 7))
;; Test enum and bitmask ;; Test enum and bitmask
(define ([t (_enum '(a b c = 4 d))] (let ([t (_enum '(a b c = 4 d))]
[s (_bitmask '(a b c = 14 d))]) [s (_bitmask '(a b c = 14 d))])
(define (check t v n) (define (check t v n)
(test n (cast v t _int))) (test #t (λ (x) (equal? x n)) (cast v t _int)))
(check t 'a 0) (check t 'a 0)
(check t 'b 1) (check t 'b 1)
(check t 'c 4) (check t 'c 4)
(check t 'd 5) (check t 'd 5)
(check t 'a 1) (check s 'a 1)
(check t 'b 2) (check s 'b 2)
(check t 'c 14) (check s 'c 14)
(check t 'd 16) (check s 'd 16))
(check t '(a b) 3))
;; 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")
;; Make sure that _enum works in non first order cases ;; Make sure that _enum works in non first order cases
(test #t ctype? (let ([enum _enum]) (enum '(x y)))) (test #t ctype? (let ([enum _enum]) (enum '(x y))))
;; Make sure that _enum checks its inputs
(let ([_enum-exn? (lambda (exn)
(and (exn:fail:contract? exn)
(regexp-match? #rx"_enum" (exn-message exn))))])
(error-test #'(_enum 1) _enum-exn?)
(error-test #'(_enum '(1)) _enum-exn?)
(error-test #'(_enum '(x = y)) _enum-exn?)
(error-test #'(_enum '(x y) #:unknown (lambda (x y) x)) _enum-exn?))
(define-cstruct _ic7i ([i1 _int] (define-cstruct _ic7i ([i1 _int]
[c7 _c7_list] [c7 _c7_list]

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

@ -797,6 +797,10 @@
;; Call this with a name (symbol or #f) and a list of symbols, where a symbol can be ;; Call this with a name (symbol or #f) and a list of symbols, where a symbol can be
;; followed by a '= and an integer to have a similar effect of C's enum. ;; followed by a '= and an integer to have a similar effect of C's enum.
(define ((_enum name) symbols [basetype _ufixint] #:unknown [unknown _enum]) (define ((_enum name) symbols [basetype _ufixint] #:unknown [unknown _enum])
(unless (list? symbols)
(raise-argument-error '_enum "list?" symbols))
(when (and (procedure? unknown) (not (procedure-arity-includes? unknown 1)))
(raise-argument-error '_enum "(if/c procedure? (procedure-arity-includes/c 1) any/c)" unknown))
(define sym->int '()) (define sym->int '())
(define int->sym '()) (define int->sym '())
(define s->c (define s->c
@ -810,8 +814,19 @@
(pair? (cddr symbols))) (pair? (cddr symbols)))
(values (caddr symbols) (cdddr symbols)) (values (caddr symbols) (cdddr symbols))
(values i (cdr symbols)))]) (values i (cdr symbols)))])
(set! sym->int (cons (cons (car symbols) i) sym->int)) (define sym (car symbols))
(set! int->sym (cons (cons i (car symbols)) int->sym)) (unless (symbol? sym)
(raise-arguments-error '_enum "key is not a symbol"
"symbols" symbols
"key" sym
"value" i))
(unless (exact-nonnegative-integer? i)
(raise-arguments-error '_enum "value is not an integer"
"symbols" symbols
"key" sym
"value" i))
(set! sym->int (cons (cons sym i) sym->int))
(set! int->sym (cons (cons i sym) int->sym))
(loop (add1 i) rest)))) (loop (add1 i) rest))))
(make-ctype basetype (make-ctype basetype
(lambda (x) (lambda (x)