mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Give multiple-values objects a tc7

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2018-06-25 15:49:34 +02:00
parent 08bf4aba30
commit 4a2d78b4d4
12 changed files with 123 additions and 98 deletions
Download patch file Download diff file Expand all files Collapse all files

16
libguile/eval.c
View file

@ -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_is_pair (l)))
return scm_car (l);
if (SCM_LIKELY (scm_i_nvalues (x) > 0))
return scm_i_value_ref (x, 0);
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))
args = scm_struct_ref (v, SCM_INUM0);
if (scm_is_values (v))
{
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;

4
libguile/i18n.c
View file

@ -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

12
libguile/numbers.c
View file

@ -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

12
libguile/posix.c
View file

@ -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
: scm_from_long (lim.rlim_cur),
(lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F
: scm_from_long (lim.rlim_max)));
return scm_values_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F
: scm_from_long (lim.rlim_cur),
(lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F
: 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,
write_port,
scm_from_int (pid)));
return scm_values_3 (read_port, write_port, scm_from_int (pid));
}
#undef FUNC_NAME

7
libguile/print.c
View file

@ -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;

2
libguile/r6rs-ports.c
View file

@ -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. */

2
libguile/scm.h
View file

@ -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

9
libguile/srfi-1.c
View file

@ -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 */
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);
return scm_values_2 (SCM_CDR (kept), SCM_CDR (dropped));
}
#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

4
libguile/srfi-14.c
View file

@ -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

104
libguile/values.c
View file

@ -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_VALUESP (obj), obj, SCM_ARG1,
SCM_ASSERT_TYPE (scm_is_values (obj), obj, SCM_ARG1,
"scm_i_extract_values_2", "values");
values = scm_struct_ref (obj, SCM_INUM0);
if (scm_ilength (values) != 2)
if (scm_i_nvalues (obj) != 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
print_values (SCM obj, SCM pwps)
{
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;
*p1 = scm_i_value_ref (obj, 0);
*p2 = scm_i_value_ref (obj, 1);
}
size_t
scm_c_nvalues (SCM obj)
{
if (SCM_LIKELY (SCM_VALUESP (obj)))
return scm_ilength (scm_struct_ref (obj, SCM_INUM0));
if (SCM_LIKELY (scm_is_values (obj)))
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)))
{
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--;
}
}
if (SCM_LIKELY (scm_is_values (obj) && idx < scm_i_nvalues (obj)))
return scm_i_value_ref (obj, idx);
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--)
ret = scm_cons (*walk, ret);
if ((uintptr_t) nvalues > (UINTPTR_MAX >> 8))
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"

27
libguile/values.h
View file

@ -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)\
&& scm_is_eq (scm_struct_vtable (x), scm_values_vtable))
#ifdef BUILDING_LIBGUILE
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);

22
libguile/vm-engine.c
View file

@ -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--)
ret = scm_inline_cons (thread, FP_REF (4 + n - 1), ret);
ret = scm_values (ret);
VM_ASSERT (nvals <= (UINTPTR_MAX >> 8), abort ());
ret = scm_words ((nvals << 8) | scm_tc7_values, nvals + 1);
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);
long len = scm_ilength (vals);
ALLOC_FRAME (1 + len);
while (len--)
{
SP_SET (len, SCM_CAR (vals));
vals = SCM_CDR (vals);
}
size_t n, nvals = scm_i_nvalues (ret);
ALLOC_FRAME (1 + nvals);
for (n = 0; n < nvals; n++)
FP_SET (n + 1, scm_i_value_ref (ret, n));
NEXT (1);
}
else