ffi: fix broken range checks in enumed type.

Reported by Paul A. Patience.

* ffi.c (make_ffi_type_enum): Do not use the cnum native type
for doing the member value calculations. Work with Lisp
numbers, and verify their range by passing them into the put
function of the underlying integer type. Duplicated code is
merged, too.

* tests/017/ffi-misc.tl: New tests. Two 64 bit ones fail
due to conversion bugs.

2 files changed, 76 insertions, 25 deletions

diff --git a/ffi.c b/ffi.c
index ced44f2f..53971cc4 100644
--- a/ffi.c
+++ b/ffi.c
@@ -3599,7 +3599,7 @@ static val make_ffi_type_enum(val syntax, val enums,
   val sym_num = make_hash(hash_weak_none, t);
   val num_sym = make_hash(hash_weak_none, nil);
   val obj = cobj(coerce(mem_t *, tft), ffi_type_cls, &ffi_type_enum_ops);
-  cnum cur = -1;
+  val cur;
   val iter;
   val enum_env = make_env(nil, nil, nil);
   val shadow_menv = make_env(nil, nil, nil);
@@ -3625,28 +3625,27 @@ static val make_ffi_type_enum(val syntax, val enums,
   tft->num_sym = num_sym;
   tft->sym_num = sym_num;
 
-  for (iter = enums; !endp(iter); iter = cdr(iter)) {
+  for (cur = negone, iter = enums; !endp(iter); iter = cdr(iter)) {
+    int_ptr_t conv_buf[2];
     val en = car(iter);
-    val nn;
+    val sym;
+
     if (symbolp(en)) {
-      val sym = en;
+      sym = en;
       if (!bindable(sym))
         uw_throwf(error_s, lit("~a: ~s member ~s isn't a bindable symbol"),
                   self, syntax, sym, nao);
-      if (cur == INT_MAX)
-        uw_throwf(error_s, lit("~a: ~s overflow at member ~s"),
-                  self, syntax, sym, nao);
+
       if (gethash(num_sym, sym))
         uw_throwf(error_s, lit("~a: ~s duplicate member ~s"),
                   self, syntax, sym, nao);
-      sethash(num_sym, sym, nn = num(++cur));
-      sethash(sym_num, nn, sym);
-      env_vbind(enum_env, sym, nn);
-      env_vbind(shadow_menv, sym, special_s);
+
+      cur = plus(cur, one);
     } else {
       val expr = cadr(en);
-      val sym = car(en);
-      val n;
+
+      sym = car(en);
+
       if (!bindable(sym))
         uw_throwf(error_s, lit("~a: ~s member ~s isn't a bindable symbol"),
                   self, syntax, sym, nao);
@@ -3654,22 +3653,20 @@ static val make_ffi_type_enum(val syntax, val enums,
         uw_throwf(error_s, lit("~a: ~s duplicate member ~s"),
                   self, syntax, sym, nao);
 
-      n = ffi_eval_expr(expr, shadow_menv, enum_env);
+      cur = ffi_eval_expr(expr, shadow_menv, enum_env);
 
-      if (!integerp(n)) {
+      if (!integerp(cur)) {
         uw_throwf(error_s, lit("~a: ~s member ~s value ~s not integer"),
-                  self, syntax, sym, n, nao);
+                  self, syntax, sym, cur, nao);
       }
-
-      cur = c_num(n, self);
-      if (cur > INT_MAX)
-        uw_throwf(error_s, lit("~a: ~s member ~s value ~s too large"),
-                  self, syntax, sym, n, nao);
-      sethash(num_sym, sym, nn = num(cur));
-      sethash(sym_num, nn, sym);
-      env_vbind(enum_env, sym, nn);
-      env_vbind(shadow_menv, sym, special_s);
     }
+
+    btft->put(btft, cur, coerce(mem_t *, conv_buf), self);
+
+    sethash(num_sym, sym, cur);
+    sethash(sym_num, cur, sym);
+    env_vbind(enum_env, sym, cur);
+    env_vbind(shadow_menv, sym, special_s);
   }
 
   return obj;
diff --git a/tests/017/ffi-misc.tl b/tests/017/ffi-misc.tl
index db510737..3b3c4438 100644
--- a/tests/017/ffi-misc.tl
+++ b/tests/017/ffi-misc.tl
@@ -16,3 +16,57 @@
 
   (test (ffi-get #b'ED7F7FEDFF00' (ffi (zarray char)))
        "\xDCED\x7F\x7F\xDCED\xDCFF"))
+
+(mtest
+  (typeof (ffi (enum a))) ffi-type
+  (typeof (ffi (enum b b0 b1 b2 (b3 -15)))) ffi-type
+  (typeof (ffi (enum c (c0 (expt 2 512))))) :error
+  (typeof (ffi (enum d d0 d0))) :error
+  (typeof (ffi (enum e (e0 0) (e0 1)))) :error)
+
+(mtest
+  (typeof (ffi (enumed uint16 m))) ffi-type
+  (typeof (ffi (enumed uint16 n n0 n1 n2 (n3 15)))) ffi-type
+  (typeof (ffi (enumed uint16 o (o0 (expt 2 512))))) :error
+  (typeof (ffi (enumed uint16 p p0 p0))) :error
+  (typeof (ffi (enumed uint16 q (q0 0) (q0 1)))) :error)
+
+(mtest
+  (typeof (ffi (enumed uint8 e (x 0) (y #xff)))) ffi-type
+  (typeof (ffi (enumed uint8 e (x -1)))) :error
+  (typeof (ffi (enumed uint8 e (x #x100)))) :error)
+
+(mtest
+  (typeof (ffi (enumed uint16 e (x 0) (y #xffff)))) ffi-type
+  (typeof (ffi (enumed uint16 e (x -1)))) :error
+  (typeof (ffi (enumed uint16 e (x #x10000)))) :error)
+
+(mtest
+  (typeof (ffi (enumed uint32 e (x 0) (y #xffffffff)))) ffi-type
+  (typeof (ffi (enumed uint32 e (x -1)))) :error
+  (typeof (ffi (enumed uint32 e (x #x100000000)))) :error)
+
+(mtest
+  (typeof (ffi (enumed uint64 e (x 0) (y #xffffffffffffffff)))) ffi-type
+  ;(typeof (ffi (enumed uint64 e (x -1)))) #:error
+  (typeof (ffi (enumed uint64 e (x #x10000000000000000)))) :error)
+
+(mtest
+  (typeof (ffi (enumed int8 e (x 0) (y #x7f)))) ffi-type
+  (typeof (ffi (enumed int8 e (x #x-81)))) :error
+  (typeof (ffi (enumed int8 e (x #x800)))) :error)
+
+(mtest
+  (typeof (ffi (enumed int16 e (x 0) (y #x7fff)))) ffi-type
+  (typeof (ffi (enumed int16 e (x #x-8001)))) :error
+  (typeof (ffi (enumed int16 e (x #x8000)))) :error)
+
+(mtest
+  (typeof (ffi (enumed int32 e (x 0) (y #x7fffffff)))) ffi-type
+  (typeof (ffi (enumed int32 e (x #x-80000001)))) :error
+  (typeof (ffi (enumed int32 e (x #x80000000)))) :error)
+
+(mtest
+  (typeof (ffi (enumed int64 e (x 0) (y #x7fffffffffffffff)))) ffi-type
+  (typeof (ffi (enumed int64 e (x #x-8000000000000001)))) :error
+  (typeof (ffi (enumed int64 e (x #x8000000000000000)))) :error)