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!.

11 files changed, 63 insertions, 21 deletions

diff --git a/libguile/alist.c b/libguile/alist.c
index 1e607f10b..b29186020 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 e5036ed8d..939631531 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 764458e36..cea545236 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 130bf28a6..08d6ad92c 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 8c20d3453..81ef3ff27 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 9544f6857..14e56bd1c 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 353a746f5..08a4b22e2 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 71d982730..ab4b2cdd1 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 7c0ce9bbd..a1b1b553a 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 89c6bc5f7..cb7d4aa12 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 e8f75b14f..ea2bfbd0c 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");