Throw an error when translating an unknown enum integer to a symbol.

Also, add a keyword argument that can be used to get the old behavior
back.

Also, improve the way the `_enum' and `_bitmask' functions are wrapped.
This commit is contained in:
Eli Barzilay 2010-11-16 14:59:48 -05:00
parent d2b1bf73e0
commit b8bbed6eb4
2 changed files with 34 additions and 34 deletions

View File

@ -759,22 +759,20 @@
;; Call this with a name (symbol) and a list of symbols, where a symbol can be ;; Call this with a name (symbol) 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 . base?) (define (_enum name symbols [basetype _ufixint] #:unknown [unknown _enum])
(define basetype (if (pair? base?) (car base?) _ufixint))
(define sym->int '()) (define sym->int '())
(define int->sym '()) (define int->sym '())
(define s->c (define s->c
(if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) (if name (string->symbol (format "enum:~a->int" name)) 'enum->int))
(define c->s
(if name (string->symbol (format "enum:int->~a" name)) 'int->enum))
(let loop ([i 0] [symbols symbols]) (let loop ([i 0] [symbols symbols])
(unless (null? symbols) (unless (null? symbols)
(let-values ([(i rest) (let-values ([(i rest) (if (and (pair? (cdr symbols))
(if (and (pair? (cdr symbols)) (eq? '= (cadr symbols))
(eq? '= (cadr symbols)) (pair? (cddr symbols)))
(pair? (cddr symbols))) (values (caddr symbols) (cdddr symbols))
(values (caddr symbols) (values i (cdr symbols)))])
(cdddr symbols))
(values i
(cdr symbols)))])
(set! sym->int (cons (cons (car symbols) i) sym->int)) (set! sym->int (cons (cons (car symbols) i) sym->int))
(set! int->sym (cons (cons i (car symbols)) int->sym)) (set! int->sym (cons (cons i (car symbols)) int->sym))
(loop (add1 i) rest)))) (loop (add1 i) rest))))
@ -784,26 +782,26 @@
(if a (if a
(cdr a) (cdr a)
(raise-type-error s->c (format "~a" (or name "enum")) x)))) (raise-type-error s->c (format "~a" (or name "enum")) x))))
(lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) (lambda (x)
(cond [(assq x int->sym) => cdr]
[(eq? unknown _enum)
(error c->s "expected a known ~a, got: ~s" basetype x)]
[(procedure? unknown) (unknown x)]
[else unknown]))))
;; Macro wrapper -- no need for a name ;; Macro wrapper -- no need for a name
(provide _enum) (provide (rename-out [_enum* _enum]))
(define-syntax (_enum stx) (define-syntax (_enum* stx)
(syntax-case stx () (syntax-case stx ()
[(_ syms) [(_ x ...)
(with-syntax ([name (syntax-local-name)]) (with-syntax ([name (syntax-local-name)]) #'(_enum 'name x ...))]
#'(_enum* 'name syms))] [id (identifier? #'id) #'_enum]))
[(_ syms basetype)
(with-syntax ([name (syntax-local-name)])
#'(_enum* 'name syms basetype))]
[id (identifier? #'id)
#'(lambda (syms . base?) (apply _enum* #f syms base?))]))
;; Call this with a name (symbol) and a list of (symbol int) or symbols like ;; Call this with a name (symbol) and a list of (symbol int) or symbols like
;; the above with '= -- but the numbers have to be specified in some way. The ;; the above with '= -- but the numbers have to be specified in some way. The
;; generated type will convert a list of these symbols into the logical-or of ;; generated type will convert a list of these symbols into the logical-or of
;; their values and back. ;; their values and back.
(define (_bitmask* name orig-symbols->integers . base?) (define (_bitmask name orig-symbols->integers . base?)
(define basetype (if (pair? base?) (car base?) _uint)) (define basetype (if (pair? base?) (car base?) _uint))
(define s->c (define s->c
(if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
@ -843,17 +841,12 @@
l))))))))) l)))))))))
;; Macro wrapper -- no need for a name ;; Macro wrapper -- no need for a name
(provide _bitmask) (provide (rename-out [_bitmask* _bitmask]))
(define-syntax (_bitmask stx) (define-syntax (_bitmask* stx)
(syntax-case stx () (syntax-case stx ()
[(_ syms) [(_ x ...)
(with-syntax ([name (syntax-local-name)]) (with-syntax ([name (syntax-local-name)]) #'(_bitmask 'name x ...))]
#'(_bitmask* 'name syms))] [id (identifier? #'id) #'_bitmask]))
[(_ syms basetype)
(with-syntax ([name (syntax-local-name)])
#'(_bitmask* 'name syms basetype))]
[id (identifier? #'id)
#'(lambda (syms . base?) (apply _bitmask* #f syms base?))]))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Custom function type macros ;; Custom function type macros

View File

@ -989,7 +989,9 @@ Although the constructors below are describes as procedures, they are
implemented as syntax, so that error messages can report a type name implemented as syntax, so that error messages can report a type name
where the syntactic context implies one. where the syntactic context implies one.
@defproc[(_enum [symbols list?] [basetype ctype? _ufixint]) @defproc[(_enum [symbols list?]
[basetype ctype? _ufixint]
[#:unknown unknown any/c (lambda (x) (error ....))])
ctype?]{ ctype?]{
Takes a list of symbols and generates an enumeration type. The Takes a list of symbols and generates an enumeration type. The
@ -1002,7 +1004,12 @@ example, the list @scheme['(x y = 10 z)] maps @scheme['x] to
@scheme[0], @scheme['y] to @scheme[10], and @scheme['z] to @scheme[0], @scheme['y] to @scheme[10], and @scheme['z] to
@scheme[11]. @scheme[11].
The @scheme[basetype] argument specifies the base type to use.} The @scheme[basetype] argument specifies the base type to use.
The @scheme[unknown] argument specifies the result of converting an
unknown integer from the foreign side: it can be a one-argument function
to be applied on the integer, or a value to return instead. The default
is to throw an exception.}
@defproc[(_bitmask [symbols (or symbol? list?)] [basetype ctype? _uint]) @defproc[(_bitmask [symbols (or symbol? list?)] [basetype ctype? _uint])
ctype?]{ ctype?]{