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

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

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;

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

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

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

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);
 	}
     }
   

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

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

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); \

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);
     }

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;
@@ -527,6 +528,12 @@ vm_error_not_a_pair (const char *subr, SCM x)
   scm_wrong_type_arg_msg (subr, 1, x, "pair");
 }
 
+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)
 {