From b8bbed6eb452712940e15b5ff7dbcdd3986c9e28 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Tue, 16 Nov 2010 14:59:48 -0500
Subject: [PATCH] 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.
---
 collects/ffi/unsafe.rkt                  | 57 +++++++++++-------------
 collects/scribblings/foreign/types.scrbl | 11 ++++-
 2 files changed, 34 insertions(+), 34 deletions(-)

diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt
index 66fd34a767..4cef8d2674 100644
--- a/collects/ffi/unsafe.rkt
+++ b/collects/ffi/unsafe.rkt
@@ -759,22 +759,20 @@
 
 ;; 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.
-(define (_enum* name symbols . base?)
-  (define basetype (if (pair? base?) (car base?) _ufixint))
+(define (_enum name symbols [basetype _ufixint] #:unknown [unknown _enum])
   (define sym->int '())
   (define int->sym '())
   (define s->c
     (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])
     (unless (null? symbols)
-      (let-values ([(i rest)
-                    (if (and (pair? (cdr symbols))
-                             (eq? '= (cadr symbols))
-                             (pair? (cddr symbols)))
-                        (values (caddr symbols)
-                                (cdddr symbols))
-                        (values i
-                                (cdr symbols)))])
+      (let-values ([(i rest) (if (and (pair? (cdr symbols))
+                                      (eq? '= (cadr symbols))
+                                      (pair? (cddr symbols)))
+                               (values (caddr symbols) (cdddr symbols))
+                               (values i (cdr symbols)))])
         (set! sym->int (cons (cons (car symbols) i) sym->int))
         (set! int->sym (cons (cons i (car symbols)) int->sym))
         (loop (add1 i) rest))))
@@ -784,26 +782,26 @@
         (if a
           (cdr a)
           (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
-(provide _enum)
-(define-syntax (_enum stx)
+(provide (rename-out [_enum* _enum]))
+(define-syntax (_enum* stx)
   (syntax-case stx ()
-    [(_ syms)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_enum* 'name syms))]
-    [(_ syms basetype)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_enum* 'name syms basetype))]
-    [id (identifier? #'id)
-     #'(lambda (syms . base?) (apply _enum* #f syms base?))]))
+    [(_ x ...)
+     (with-syntax ([name (syntax-local-name)]) #'(_enum 'name x ...))]
+    [id (identifier? #'id) #'_enum]))
 
 ;; 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
 ;; generated type will convert a list of these symbols into the logical-or of
 ;; 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 s->c
     (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
@@ -843,17 +841,12 @@
                       l)))))))))
 
 ;; Macro wrapper -- no need for a name
-(provide _bitmask)
-(define-syntax (_bitmask stx)
+(provide (rename-out [_bitmask* _bitmask]))
+(define-syntax (_bitmask* stx)
   (syntax-case stx ()
-    [(_ syms)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_bitmask* 'name syms))]
-    [(_ syms basetype)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_bitmask* 'name syms basetype))]
-    [id (identifier? #'id)
-     #'(lambda (syms . base?) (apply _bitmask* #f syms base?))]))
+    [(_ x ...)
+     (with-syntax ([name (syntax-local-name)]) #'(_bitmask 'name x ...))]
+    [id (identifier? #'id) #'_bitmask]))
 
 ;; ----------------------------------------------------------------------------
 ;; Custom function type macros
diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl
index 565e97690d..1f0c632aa3 100644
--- a/collects/scribblings/foreign/types.scrbl
+++ b/collects/scribblings/foreign/types.scrbl
@@ -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
 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?]{
 
 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[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])
          ctype?]{