[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/05: Attempt to mutate residualized literal pair throw
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/05: Attempt to mutate residualized literal pair throws exception |
|
Date: |
Tue, 18 Apr 2017 15:38:36 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 6e573a0885d24d9ed36141ddf561c8b8b2e288e9
Author: Andy Wingo <address@hidden>
Date: Mon Apr 17 11:26:17 2017 +0200
Attempt to mutate residualized literal pair throws exception
* libguile/validate.h (SCM_VALIDATE_MUTABLE_PAIR):
* libguile/pairs.h (scm_is_mutable_pair): New internal definitions.
* libguile/pairs.c (scm_set_car_x, scm_set_cdr_x): Validate mutable
pairs.
* libguile/alist.c (scm_assq_set_x, scm_assv_set_x, scm_assoc_set_x):
* libguile/list.c (scm_reverse_x, scm_list_set_x, scm_list_cdr_set_x):
* libguile/srcprop.c (scm_make_srcprops):
* libguile/srfi-1.c (scm_srfi1_append_reverse_x)
(scm_srfi1_delete_duplicates_x):
* libguile/symbols.c (scm_symbol_fset_x, scm_symbol_pset_x):
* libguile/sort.c (scm_merge_list_x): Use scm_set_car_x / scm_set_cdr_x
instead of the macros, so as to check for mutable pairs.
(SCM_VALIDATE_MUTABLE_LIST): New internal helper macro.
(scm_sort_x, scm_stable_sort_x, scm_sort_list_x): Use
SCM_VALIDATE_MUTABLE_LIST.
* libguile/vm-engine.c (VM_VALIDATE_MUTABLE_PAIR): New definition.
(set-car!, set-cdr!): Use VM_VALIDATE_MUTABLE_PAIR. Fix error message
for set-cdr!.
---
libguile/alist.c | 6 +++---
libguile/list.c | 8 ++++----
libguile/pairs.c | 4 ++--
libguile/pairs.h | 16 ++++++++++++++++
libguile/sort.c | 20 ++++++++++++++++----
libguile/srcprop.c | 2 +-
libguile/srfi-1.c | 6 +++---
libguile/symbols.c | 4 ++--
libguile/validate.h | 5 +++++
libguile/vm-engine.c | 6 ++++--
libguile/vm.c | 7 +++++++
11 files changed, 63 insertions(+), 21 deletions(-)
diff --git a/libguile/alist.c b/libguile/alist.c
index 1e607f1..b291860 100644
--- a/libguile/alist.c
+++ b/libguile/alist.c
@@ -290,7 +290,7 @@ SCM_DEFINE (scm_assq_set_x, "assq-set!", 3, 0, 0,
handle = scm_sloppy_assq (key, alist);
if (scm_is_pair (handle))
{
- SCM_SETCDR (handle, val);
+ scm_set_cdr_x (handle, val);
return alist;
}
else
@@ -308,7 +308,7 @@ SCM_DEFINE (scm_assv_set_x, "assv-set!", 3, 0, 0,
handle = scm_sloppy_assv (key, alist);
if (scm_is_pair (handle))
{
- SCM_SETCDR (handle, val);
+ scm_set_cdr_x (handle, val);
return alist;
}
else
@@ -326,7 +326,7 @@ SCM_DEFINE (scm_assoc_set_x, "assoc-set!", 3, 0, 0,
handle = scm_sloppy_assoc (key, alist);
if (scm_is_pair (handle))
{
- SCM_SETCDR (handle, val);
+ scm_set_cdr_x (handle, val);
return alist;
}
else
diff --git a/libguile/list.c b/libguile/list.c
index e5036ed..9396315 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -391,14 +391,14 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
while (scm_is_pair (lst))
{
SCM old_tail = SCM_CDR (lst);
- SCM_SETCDR (lst, tail);
+ scm_set_cdr_x (lst, tail);
tail = lst;
lst = old_tail;
}
if (SCM_LIKELY (SCM_NULL_OR_NIL_P (lst)))
{
- SCM_SETCDR (old_lst, new_tail);
+ scm_set_cdr_x (old_lst, new_tail);
return tail;
}
@@ -454,7 +454,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
unsigned long int i = scm_to_ulong (k);
while (scm_is_pair (lst)) {
if (i == 0) {
- SCM_SETCAR (lst, val);
+ scm_set_car_x (lst, val);
return val;
} else {
--i;
@@ -500,7 +500,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
size_t i = scm_to_size_t (k);
while (scm_is_pair (lst)) {
if (i == 0) {
- SCM_SETCDR (lst, val);
+ scm_set_cdr_x (lst, val);
return val;
} else {
--i;
diff --git a/libguile/pairs.c b/libguile/pairs.c
index 764458e..cea5452 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -91,7 +91,7 @@ SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
"by @code{set-car!} is unspecified.")
#define FUNC_NAME s_scm_set_car_x
{
- SCM_VALIDATE_CONS (1, pair);
+ SCM_VALIDATE_MUTABLE_PAIR (1, pair);
SCM_SETCAR (pair, value);
return SCM_UNSPECIFIED;
}
@@ -104,7 +104,7 @@ SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
"by @code{set-cdr!} is unspecified.")
#define FUNC_NAME s_scm_set_cdr_x
{
- SCM_VALIDATE_CONS (1, pair);
+ SCM_VALIDATE_MUTABLE_PAIR (1, pair);
SCM_SETCDR (pair, value);
return SCM_UNSPECIFIED;
}
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 130bf28..08d6ad9 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -176,6 +176,22 @@ scm_cdr (SCM x)
}
#endif
+#ifdef BUILDING_LIBGUILE
+static inline int
+scm_is_mutable_pair (SCM x)
+{
+ /* Guile embeds literal pairs into compiled object files. It's not
+ valid Scheme to mutate literal values. Two practical reasons to
+ enforce this restriction are to allow literals to share share
+ structure (pairs) with other literals in the compilation unit, and
+ to allow literals containing immediates to be allocated in the
+ read-only, shareable section of the file. Attempting to mutate a
+ pair in the read-only section would cause a segmentation fault, so
+ to avoid that, we really do need to enforce the restriction. */
+ return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (x));
+}
+#endif /* BUILDING_LIBGUILE */
+
SCM_API SCM scm_cons2 (SCM w, SCM x, SCM y);
SCM_API SCM scm_pair_p (SCM x);
SCM_API SCM scm_set_car_x (SCM pair, SCM value);
diff --git a/libguile/sort.c b/libguile/sort.c
index 8c20d34..81ef3ff 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -306,22 +306,22 @@ scm_merge_list_x (SCM alist, SCM blist,
SCM_TICK;
if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
- SCM_SETCDR (last, blist);
+ scm_set_cdr_x (last, blist);
blist = SCM_CDR (blist);
blen--;
}
else
{
- SCM_SETCDR (last, alist);
+ scm_set_cdr_x (last, alist);
alist = SCM_CDR (alist);
alen--;
}
last = SCM_CDR (last);
}
if ((alen > 0) && (blen == 0))
- SCM_SETCDR (last, alist);
+ scm_set_cdr_x (last, alist);
else if ((alen == 0) && (blen > 0))
- SCM_SETCDR (last, blist);
+ scm_set_cdr_x (last, blist);
}
return build;
} /* scm_merge_list_x */
@@ -398,6 +398,14 @@ scm_merge_list_step (SCM * seq, SCM less, long n)
} /* scm_merge_list_step */
+#define SCM_VALIDATE_MUTABLE_LIST(pos, lst) \
+ do { \
+ SCM walk; \
+ for (walk = lst; !scm_is_null_or_nil (walk); walk = SCM_CDR (walk)) \
+ SCM_VALIDATE_MUTABLE_PAIR (pos, walk); \
+ } while (0)
+
+
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
@@ -414,6 +422,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
if (scm_is_pair (items))
{
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ SCM_VALIDATE_MUTABLE_LIST (1, items);
return scm_merge_list_step (&items, less, len);
}
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
@@ -533,6 +542,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
if (scm_is_pair (items))
{
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ SCM_VALIDATE_MUTABLE_LIST (1, items);
return scm_merge_list_step (&items, less, len);
}
else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
@@ -596,6 +606,8 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ SCM_VALIDATE_MUTABLE_LIST (1, items);
+
return scm_merge_list_step (&items, less, len);
}
#undef FUNC_NAME
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 9544f68..14e56bd 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -143,7 +143,7 @@ scm_make_srcprops (long line, int col, SCM filename, SCM
copy, SCM alist)
{
alist = scm_acons (scm_sym_filename, filename, alist);
if (scm_is_null (old_alist))
- SCM_SETCDR (scm_last_alist_filename, alist);
+ scm_set_cdr_x (scm_last_alist_filename, alist);
}
}
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 353a746..08a4b22 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -119,7 +119,7 @@ SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!",
2, 0, 0,
{
SCM newtail;
- while (scm_is_pair (revhead))
+ while (scm_is_mutable_pair (revhead))
{
/* take the first cons cell from revhead */
newtail = revhead;
@@ -548,7 +548,7 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x,
"delete-duplicates!", 1, 1, 0,
if (scm_is_eq (l, endret))
{
/* not equal to any, so append this pair */
- SCM_SETCDR (endret, lst);
+ scm_set_cdr_x (endret, lst);
endret = lst;
break;
}
@@ -557,7 +557,7 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x,
"delete-duplicates!", 1, 1, 0,
}
/* terminate, in case last element was deleted */
- SCM_SETCDR (endret, SCM_EOL);
+ scm_set_cdr_x (endret, SCM_EOL);
}
/* demand that lst was a proper list */
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 71d9827..ab4b2cd 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -449,7 +449,7 @@ SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
#define FUNC_NAME s_scm_symbol_fset_x
{
SCM_VALIDATE_SYMBOL (1, s);
- SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val);
+ scm_set_car_x (SCM_CELL_OBJECT_3 (s), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -461,7 +461,7 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
#define FUNC_NAME s_scm_symbol_pset_x
{
SCM_VALIDATE_SYMBOL (1, s);
- SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val);
+ scm_set_cdr_x (SCM_CELL_OBJECT_3 (s), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/validate.h b/libguile/validate.h
index 7c0ce9b..a1b1b55 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -240,6 +240,11 @@
#define SCM_VALIDATE_CONS(pos, scm) \
SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_pair, "pair")
+#ifdef BUILDING_LIBGUILE
+#define SCM_VALIDATE_MUTABLE_PAIR(pos, scm) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_mutable_pair, "mutable pair")
+#endif /* BUILDING_LIBGUILE */
+
#define SCM_VALIDATE_LIST(pos, lst) \
do { \
SCM_ASSERT (scm_ilength (lst) >= 0, lst, pos, FUNC_NAME); \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 89c6bc5..cb7d4aa 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -424,6 +424,8 @@
VM_VALIDATE (x, SCM_CHARP, proc, char)
#define VM_VALIDATE_PAIR(x, proc) \
VM_VALIDATE (x, scm_is_pair, proc, pair)
+#define VM_VALIDATE_MUTABLE_PAIR(x, proc) \
+ VM_VALIDATE (x, scm_is_mutable_pair, proc, mutable_pair)
#define VM_VALIDATE_STRING(obj, proc) \
VM_VALIDATE (obj, scm_is_string, proc, string)
#define VM_VALIDATE_STRUCT(obj, proc) \
@@ -2359,7 +2361,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
UNPACK_12_12 (op, a, b);
x = SP_REF (a);
y = SP_REF (b);
- VM_VALIDATE_PAIR (x, "set-car!");
+ VM_VALIDATE_MUTABLE_PAIR (x, "set-car!");
SCM_SETCAR (x, y);
NEXT (1);
}
@@ -2375,7 +2377,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
UNPACK_12_12 (op, a, b);
x = SP_REF (a);
y = SP_REF (b);
- VM_VALIDATE_PAIR (x, "set-car!");
+ VM_VALIDATE_MUTABLE_PAIR (x, "set-cdr!");
SCM_SETCDR (x, y);
NEXT (1);
}
diff --git a/libguile/vm.c b/libguile/vm.c
index e8f75b1..ea2bfbd 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -429,6 +429,7 @@ static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
+static void vm_error_not_a_mutable_pair (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
@@ -528,6 +529,12 @@ vm_error_not_a_pair (const char *subr, SCM x)
}
static void
+vm_error_not_a_mutable_pair (const char *subr, SCM x)
+{
+ scm_wrong_type_arg_msg (subr, 1, x, "mutable pair");
+}
+
+static void
vm_error_not_a_string (const char *subr, SCM x)
{
scm_wrong_type_arg_msg (subr, 1, x, "string");