Give multiple-values objects a tc7

* libguile/scm.h (scm_tc7_values): New tc7.  Never seen by Scheme, so we
  don't need to update it anywhere else.
* libguile/values.h (scm_is_values): New public static inline function.
  (scm_i_nvalues, scm_i_value_ref): New private static inline
  functions.
  (SCM_VALUESP): Use scm_is_value.
  (scm_values_2, scm_values_3): New functions.
  (scm_values_vtable): Remove; values objects are not structs any more.
* libguile/values.c (scm_i_extract_values_2): Adapt to new values
  representation.
  (print_values): Remove now-unused function.
  (scm_c_nvalues): Use scm_i_nvalues.
  (scm_c_value_ref): Use scm_i_value_ref.
  (scm_values, scm_c_values): Make the new-style objects, which store
  their values inline.
  (scm_values_2, scm_values_3): New helpers, to avoid consing little
  useless lists.
* libguile/vm-engine.c (halt, subr-call)
* libguile/eval.c (eval): Adapt to new values representation.
* libguile/i18n.c (scm_locale_string_to_integer)
  (scm_locale_string_to_integer)
* libguile/numbers.c (scm_i_floor_divide, scm_i_ceiling_divide)
  (scm_i_truncate_divide, scm_i_centered_divide, scm_i_round_divide)
  (scm_i_exact_integer_sqrt)
* libguile/r6rs-ports.c (make_bytevector_output_port)
* libguile/srfi-1.c (scm_srfi1_partition, scm_srfi1_partition_x)
* libguile/srfi-14.c (scm_char_set_diff_plus_intersection)
  (scm_char_set_diff_plus_intersection_x)
* libguile/posix.c (scm_getrlimit, scm_open_process): Adapt to use
  scm_values_2 or scm_values_3.
* libguile/print.c (iprin1): Add printer for values objects.

libguile/eval.c

@@ -224,13 +224,12 @@ static void error_unrecognized_keyword (SCM proc, SCM kw)
 static SCM
 truncate_values (SCM x)
 {
-  if (SCM_LIKELY (!SCM_VALUESP (x)))
+  if (SCM_LIKELY (!scm_is_values (x)))
     return x;
   else
     {
-      SCM l = scm_struct_ref (x, SCM_INUM0);
+      if (SCM_LIKELY (scm_i_nvalues (x) > 0))
-      if (SCM_LIKELY (scm_is_pair (l)))
+        return scm_i_value_ref (x, 0);
-        return scm_car (l);
       else
         {
           scm_ithrow (scm_from_latin1_symbol ("vm-run"),
@@ -368,8 +367,13 @@ eval (SCM x, SCM env)
         /* `proc' is the consumer.  */
         proc = EVAL1 (CDR (mx), env);
         v = scm_call_0 (producer);
-        if (SCM_VALUESP (v))
+        if (scm_is_values (v))
-          args = scm_struct_ref (v, SCM_INUM0);
+          {
+            size_t i = scm_i_nvalues (v);
+            args = SCM_EOL;
+            while (i--)
+              args = scm_cons (scm_i_value_ref (v, i), args);
+          }
         else
           args = scm_list_1 (v);
         goto apply_proc;

libguile/i18n.c

@@ -1360,7 +1360,7 @@ SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
   else
     result = scm_from_long (c_result);
 
-  return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
+  return scm_values_2 (result, scm_from_long (c_endptr - c_str));
 }
 #undef FUNC_NAME
 
@@ -1404,7 +1404,7 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
   else
     result = scm_from_double (c_result);
 
-  return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
+  return scm_values_2 (result, scm_from_long (c_endptr - c_str));
 }
 #undef FUNC_NAME
 

libguile/numbers.c

@@ -1500,7 +1500,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_floor_divide, "floor/", 2, 0, 0,
   SCM q, r;
 
   scm_floor_divide(x, y, &q, &r);
-  return scm_values (scm_list_2 (q, r));
+  return scm_values_2 (q, r);
 }
 #undef FUNC_NAME
 
@@ -2038,7 +2038,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide, "ceiling/", 2, 0, 0,
   SCM q, r;
 
   scm_ceiling_divide(x, y, &q, &r);
-  return scm_values (scm_list_2 (q, r));
+  return scm_values_2 (q, r);
 }
 #undef FUNC_NAME
 
@@ -2529,7 +2529,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide, "truncate/", 2, 0, 0,
   SCM q, r;
 
   scm_truncate_divide(x, y, &q, &r);
-  return scm_values (scm_list_2 (q, r));
+  return scm_values_2 (q, r);
 }
 #undef FUNC_NAME
 
@@ -3140,7 +3140,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0,
   SCM q, r;
 
   scm_centered_divide(x, y, &q, &r);
-  return scm_values (scm_list_2 (q, r));
+  return scm_values_2 (q, r);
 }
 #undef FUNC_NAME
 
@@ -3815,7 +3815,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_round_divide, "round/", 2, 0, 0,
   SCM q, r;
 
   scm_round_divide(x, y, &q, &r);
-  return scm_values (scm_list_2 (q, r));
+  return scm_values_2 (q, r);
 }
 #undef FUNC_NAME
 
@@ -10094,7 +10094,7 @@ SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
   SCM s, r;
 
   scm_exact_integer_sqrt (k, &s, &r);
-  return scm_values (scm_list_2 (s, r));
+  return scm_values_2 (s, r);
 }
 #undef FUNC_NAME
 

libguile/posix.c

@@ -599,10 +599,10 @@ SCM_DEFINE (scm_getrlimit, "getrlimit", 1, 0, 0,
   if (getrlimit (iresource, &lim) != 0)
     scm_syserror (FUNC_NAME);
 
-  return scm_values (scm_list_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F
+  return scm_values_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F
-                                 : scm_from_long (lim.rlim_cur),
+                       : scm_from_long (lim.rlim_cur),
-                                 (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F
+                       (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F
-                                 : scm_from_long (lim.rlim_max)));
+                       : scm_from_long (lim.rlim_max));
 }
 #undef FUNC_NAME
 
@@ -1435,9 +1435,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
                                        SCM_FPORT_OPTION_NOT_SEEKABLE);
     }
 
-  return scm_values (scm_list_3 (read_port,
+  return scm_values_3 (read_port, write_port, scm_from_int (pid));
-                                 write_port,
-                                 scm_from_int (pid)));
 }
 #undef FUNC_NAME
 

libguile/print.c

@@ -60,6 +60,7 @@
 #include "struct.h"
 #include "symbols.h"
 #include "syntax.h"
+#include "values.h"
 #include "variable.h"
 #include "vectors.h"
 #include "vm.h"
@@ -703,6 +704,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	case scm_tc7_variable:
 	  scm_i_variable_print (exp, port, pstate);
 	  break;
+        case scm_tc7_values:
+          scm_puts ("#<values (", port);
+          print_vector_or_weak_vector (exp, scm_i_nvalues (exp),
+                                       scm_c_value_ref, port, pstate);
+          scm_puts (">", port);
+          break;
 	case scm_tc7_program:
 	  scm_i_program_print (exp, port, pstate);
 	  break;

libguile/r6rs-ports.c

@@ -763,7 +763,7 @@ make_bytevector_output_port (void)
 
   SCM_NEWSMOB (proc, bytevector_output_port_procedure, buf);
 
-  return scm_values (scm_list_2 (port, proc));
+  return scm_values_2 (port, proc);
 }
 
 /* Write octets from WRITE_BUF to the backing store.  */

libguile/scm.h

@@ -489,7 +489,7 @@ typedef uintptr_t scm_t_bits;
 #define scm_tc7_keyword		0x35
 #define scm_tc7_atomic_box	0x37
 #define scm_tc7_syntax		0x3d
-#define scm_tc7_unused_3f	0x3f
+#define scm_tc7_values		0x3f
 #define scm_tc7_program		0x45
 #define scm_tc7_vm_cont		0x47
 #define scm_tc7_bytevector	0x4d

libguile/srfi-1.c

@@ -818,12 +818,7 @@ SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
       dropped_tail = new_tail;
     }
   }
-  /* re-use the initial conses for the values list */
+  return scm_values_2 (SCM_CDR (kept), SCM_CDR (dropped));
-  SCM_SETCAR(kept, SCM_CDR(kept));
-  SCM_SETCDR(kept, dropped);
-  SCM_SETCAR(dropped, SCM_CDR(dropped));
-  SCM_SETCDR(dropped, SCM_EOL);
-  return scm_values(kept);
 }
 #undef FUNC_NAME
 
@@ -877,7 +872,7 @@ SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
   *tp = SCM_EOL;
   *fp = SCM_EOL;
 
-  return scm_values (scm_list_2 (tlst, flst));
+  return scm_values_2 (tlst, flst);
 }
 #undef FUNC_NAME
 

libguile/srfi-14.c

@@ -1900,7 +1900,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1
       charsets_intersection (p, r);
       rest = SCM_CDR (rest);
     }
-  return scm_values (scm_list_2 (res1, res2));
+  return scm_values_2 (res1, res2);
 }
 #undef FUNC_NAME
 
@@ -1988,7 +1988,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
     scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
   cs1 = diff;
   cs2 = intersect;
-  return scm_values (scm_list_2 (cs1, cs2));
+  return scm_values_2 (cs1, cs2);
 }
 #undef FUNC_NAME
 

libguile/values.c

@@ -21,59 +21,37 @@
 # include <config.h>
 #endif
 
-#include "eval.h"
 #include "feature.h"
 #include "gc.h"
 #include "gsubr.h"
 #include "list.h"
 #include "numbers.h"
 #include "pairs.h"
-#include "ports.h"
-#include "strings.h"
-#include "struct.h"
 
 #include "values.h"
 
 
-SCM scm_values_vtable;
-
 /* OBJ must be a values object containing exactly two values.
    scm_i_extract_values_2 puts those two values into *p1 and *p2.  */
 void
 scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
 {
-  SCM values;
+  SCM_ASSERT_TYPE (scm_is_values (obj), obj, SCM_ARG1,
-
-  SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1,
 		   "scm_i_extract_values_2", "values");
-  values = scm_struct_ref (obj, SCM_INUM0);
+  if (scm_i_nvalues (obj) != 2)
-  if (scm_ilength (values) != 2)
     scm_wrong_type_arg_msg
       ("scm_i_extract_values_2", SCM_ARG1, obj,
        "a values object containing exactly two values");
-  *p1 = SCM_CAR (values);
-  *p2 = SCM_CADR (values);
-}
 
-static SCM
+  *p1 = scm_i_value_ref (obj, 0);
-print_values (SCM obj, SCM pwps)
+  *p2 = scm_i_value_ref (obj, 1);
-{
-  SCM values = scm_struct_ref (obj, SCM_INUM0);
-  SCM port = SCM_PORT_WITH_PS_PORT (pwps);
-  scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
-
-  scm_puts ("#<values ", port);
-  scm_iprin1 (values, port, ps);
-  scm_puts (">", port);
-
-  return SCM_UNSPECIFIED;
 }
 
 size_t
 scm_c_nvalues (SCM obj)
 {
-  if (SCM_LIKELY (SCM_VALUESP (obj)))
+  if (SCM_LIKELY (scm_is_values (obj)))
-    return scm_ilength (scm_struct_ref (obj, SCM_INUM0));
+    return scm_i_nvalues (obj);
   else
     return 1;
 }
@@ -81,18 +59,8 @@ scm_c_nvalues (SCM obj)
 SCM
 scm_c_value_ref (SCM obj, size_t idx)
 {
-  if (SCM_LIKELY (SCM_VALUESP (obj)))
+  if (SCM_LIKELY (scm_is_values (obj) && idx < scm_i_nvalues (obj)))
-    {
+    return scm_i_value_ref (obj, idx);
-      SCM values = scm_struct_ref (obj, SCM_INUM0);
-      size_t i = idx;
-      while (SCM_LIKELY (scm_is_pair (values)))
-        {
-          if (i == 0)
-            return SCM_CAR (values);
-          values = SCM_CDR (values);
-          i--;
-        }
-    }
   else if (idx == 0)
     return obj;
 
@@ -119,7 +87,17 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
   if (n == 1)
     result = SCM_CAR (args);
   else
-    result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
+    {
+      size_t i;
+
+      if ((size_t) n > (size_t) (UINTPTR_MAX >> 8))
+        scm_error (scm_out_of_range_key, FUNC_NAME, "Too many values",
+                   SCM_EOL, SCM_EOL);
+
+      result = scm_words ((((scm_t_bits) n) << 8) | scm_tc7_values, n + 1);
+      for (i = 0; i < n; i++, args = SCM_CDR (args))
+        SCM_SET_CELL_OBJECT (result, i + 1, SCM_CAR (args));
+    }
 
   return result;
 }
@@ -128,24 +106,52 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
 SCM
 scm_c_values (SCM *base, size_t nvalues)
 {
-  SCM ret, *walk;
+  SCM ret;
+  size_t i;
 
   if (nvalues == 1)
     return *base;
 
-  for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--)
+  if ((uintptr_t) nvalues > (UINTPTR_MAX >> 8))
-    ret = scm_cons (*walk, ret);
+    scm_error (scm_out_of_range_key, "scm_c_values", "Too many values",
+               SCM_EOL, SCM_EOL);
 
-  return scm_values (ret);
+  ret = scm_words ((((scm_t_bits) nvalues) << 8) | scm_tc7_values, nvalues + 1);
+
+  for (i = 0; i < nvalues; i++)
+    SCM_SET_CELL_OBJECT (ret, i + 1, base[i]);
+
+  return ret;
+}
+
+SCM
+scm_values_2 (SCM a, SCM b)
+{
+  SCM ret;
+
+  ret = scm_words ((2 << 8) | scm_tc7_values, 3);
+  SCM_SET_CELL_OBJECT_1 (ret, a);
+  SCM_SET_CELL_OBJECT_2 (ret, b);
+
+  return ret;
+}
+
+SCM
+scm_values_3 (SCM a, SCM b, SCM c)
+{
+  SCM ret;
+
+  ret = scm_words ((3 << 8) | scm_tc7_values, 4);
+  SCM_SET_CELL_OBJECT_1 (ret, a);
+  SCM_SET_CELL_OBJECT_2 (ret, b);
+  SCM_SET_CELL_OBJECT_3 (ret, c);
+
+  return ret;
 }
 
 void
 scm_init_values (void)
 {
-  SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);
-
-  scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pw"), print);
-
   scm_add_feature ("values");
 
 #include "values.x"

libguile/values.h

@@ -22,17 +22,36 @@
 
 
 
-#include "libguile/struct.h"
+#include "libguile/gc.h"
 
-SCM_API SCM scm_values_vtable;
+static inline int
+scm_is_values (SCM x)
+{
+  return SCM_HAS_TYP7 (x, scm_tc7_values);
+}
 
-#define SCM_VALUESP(x) (SCM_STRUCTP (x)\
+#ifdef BUILDING_LIBGUILE
-                        && scm_is_eq (scm_struct_vtable (x), scm_values_vtable))
+static inline size_t
+scm_i_nvalues (SCM x)
+{
+  return SCM_CELL_WORD_0 (x) >> 8;
+}
+
+static inline SCM
+scm_i_value_ref (SCM x, size_t n)
+{
+  return SCM_CELL_OBJECT (x, n+1);
+}
+#endif
+
+#define SCM_VALUESP(x) (scm_is_values (x))
 
 SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
 
 SCM_API SCM scm_values (SCM args);
 SCM_API SCM scm_c_values (SCM *base, size_t n);
+SCM_API SCM scm_values_2 (SCM a, SCM b);
+SCM_API SCM scm_values_3 (SCM a, SCM b, SCM c);
 SCM_API size_t scm_c_nvalues (SCM obj);
 SCM_API SCM scm_c_value_ref (SCM obj, size_t idx);
 SCM_INTERNAL void scm_init_values (void);

libguile/vm-engine.c

@@ -342,11 +342,11 @@ VM_NAME (scm_i_thread *thread, jmp_buf *registers, int resume)
       else
         {
           uint32_t n;
-          ret = SCM_EOL;
           SYNC_IP ();
-          for (n = nvals; n > 0; n--)
+          VM_ASSERT (nvals <= (UINTPTR_MAX >> 8), abort ());
-            ret = scm_inline_cons (thread, FP_REF (4 + n - 1), ret);
+          ret = scm_words ((nvals << 8) | scm_tc7_values, nvals + 1);
-          ret = scm_values (ret);
+          for (n = 0; n < nvals; n++)
+            SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (4 + n - 1));
         }
 
       VP->ip = SCM_FRAME_RETURN_ADDRESS (VP->fp);
@@ -608,16 +608,12 @@ VM_NAME (scm_i_thread *thread, jmp_buf *registers, int resume)
       ret = scm_apply_subr (sp, FRAME_LOCALS_COUNT ());
       CACHE_SP ();
 
-      if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+      if (SCM_UNLIKELY (scm_is_values (ret)))
         {
-          SCM vals = scm_struct_ref (ret, SCM_INUM0);
+          size_t n, nvals = scm_i_nvalues (ret);
-          long len = scm_ilength (vals);
+          ALLOC_FRAME (1 + nvals);
-          ALLOC_FRAME (1 + len);
+          for (n = 0; n < nvals; n++)
-          while (len--)
+            FP_SET (n + 1, scm_i_value_ref (ret, n));
-            {
-              SP_SET (len, SCM_CAR (vals));
-              vals = SCM_CDR (vals);
-            }
           NEXT (1);
         }
       else