clouseau: restrict modification of descendant place when appropriate

In some cases, READ-ONLY-PLACE is not enough: the SYMBOL-NAME of a
symbol is read-only as a place. However, it is also a bad idea to
modify the STRING that is the name of the symbol even if this doesn't
change the value of the symbol name place.

To start addressing this issue, this change adds SUPPORTSP methods
that query ancestor places when determining whether SETF or
REMOVE-VALUE is allowed for a given place. Ancestor places are queried
via (supportsp ANCESTOR 'modify-descendants) which typically traverses
the path to the root place and returns true. However, if an ancestor
along the path returns false, the modification is not allowed. This
way, a symbol name place can to some extent prevent the STRING that is
the name of the symbol from being modified.

9 files changed, 73 insertions, 30 deletions

diff --git a/Apps/Clouseau/src/objects/array.lisp b/Apps/Clouseau/src/objects/array.lisp
index 22b709b2..0461f33d 100644
--- a/Apps/Clouseau/src/objects/array.lisp
+++ b/Apps/Clouseau/src/objects/array.lisp
@@ -23,7 +23,8 @@
 
 ;;; `array-dimensions-place'
 
-(defclass array-dimensions-place (basic-place)
+(defclass array-dimensions-place (read-only-descendants-mixin
+                                  basic-place)
   ())
 
 (defmethod supportsp ((place array-dimensions-place) (operation (eql 'setf)))
@@ -151,7 +152,7 @@
 
 (defun inspect-element-type-and-total-size (object stream)
   (formatting-row (stream)
-    (format-place-cells stream object 'reader-place 'array-element-type
+    (format-place-cells stream object 'deep-reader-place 'array-element-type
                         :label "Element type")
     (multiple-value-bind (class cell)
         (if (vectorp object)
diff --git a/Apps/Clouseau/src/objects/character.lisp b/Apps/Clouseau/src/objects/character.lisp
index 64d32322..7ed13e38 100644
--- a/Apps/Clouseau/src/objects/character.lisp
+++ b/Apps/Clouseau/src/objects/character.lisp
@@ -2,12 +2,11 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2019-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2019-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
 ;;; Inspection methods for characters.
-;;;
 
 (cl:in-package #:clouseau)
 
@@ -41,8 +40,8 @@
                                        (style  (eql :expanded-body))
                                        (stream t))
   (formatting-table (stream)
-    (format-place-row stream object 'reader-place 'char-name :label "Name")
-    (format-place-row stream object 'reader-place 'char-code :label "Code")
+    (format-place-row stream object 'deep-reader-place 'char-name :label "Name")
+    (format-place-row stream object 'deep-reader-place 'char-code :label "Code")
     (when-let ((weight (digit-char-p object)))
       (format-place-row stream object 'pseudo-place weight :label "Weight"))))
 
diff --git a/Apps/Clouseau/src/objects/class.lisp b/Apps/Clouseau/src/objects/class.lisp
index 8457cfdc..f5d57c3e 100644
--- a/Apps/Clouseau/src/objects/class.lisp
+++ b/Apps/Clouseau/src/objects/class.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
@@ -47,7 +47,7 @@
 ;;; interest. As a result, such lists can be shown as a list or as the
 ;;; graph induced by the relation.
 
-(defclass class-list-place (read-only-place)
+(defclass class-list-place (deep-read-only-place)
   ())
 
 (macrolet
diff --git a/Apps/Clouseau/src/objects/function.lisp b/Apps/Clouseau/src/objects/function.lisp
index acaf0cca..a4874188 100644
--- a/Apps/Clouseau/src/objects/function.lisp
+++ b/Apps/Clouseau/src/objects/function.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
@@ -173,11 +173,11 @@
         (multiple-value-bind (lambda-list lambda-list-p)
             (function-lambda-list object expression)
           ;; Name
-          (format-place-row stream object 'reader-place 'function-name
+          (format-place-row stream object 'deep-reader-place 'function-name
                             :label "Name")
           ;; Lambda list
           (formatting-row (stream)
-            (formatting-place (object 'pseudo-place lambda-list present inspect)
+            (formatting-place (object 'deep-pseudo-place lambda-list present inspect)
               (with-style (stream :slot-like)
                 (formatting-cell (stream) (write-string "Lambda list" stream))
                 (formatting-cell (stream) (present stream)))
@@ -189,7 +189,7 @@
                    (inspect stream)))))))
         ;; Type
         #+sbcl
-        (format-place-row stream object 'reader-place 'sb-introspect:function-type
+        (format-place-row stream object 'deep-reader-place 'sb-introspect:function-type
                           :label "Type")))
     ;; Documentation
     (print-documentation object stream)
diff --git a/Apps/Clouseau/src/objects/hash-table.lisp b/Apps/Clouseau/src/objects/hash-table.lisp
index 956f2a1f..ad3bba8f 100644
--- a/Apps/Clouseau/src/objects/hash-table.lisp
+++ b/Apps/Clouseau/src/objects/hash-table.lisp
@@ -2,12 +2,11 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
 ;;; Places, inspection methods and commands for hash-tables.
-;;;
 
 (cl:in-package #:clouseau)
 
@@ -94,22 +93,22 @@
   (with-preserved-cursor-x (stream)
     (formatting-table (stream)
       (formatting-row (stream)
-        (format-place-cells stream object 'reader-place 'hash-table-test
+        (format-place-cells stream object 'deep-reader-place 'hash-table-test
                             :label "Test")
-        #+sbcl (format-place-cells stream object 'reader-place 'sb-ext:hash-table-synchronized-p
+        #+sbcl (format-place-cells stream object 'deep-reader-place 'sb-ext:hash-table-synchronized-p
                                    :label "Synchronized")
-        #+sbcl (format-place-cells stream object 'reader-place 'sb-ext:hash-table-weakness
+        #+sbcl (format-place-cells stream object 'deep-reader-place 'sb-ext:hash-table-weakness
                                    :label "Weakness"))
       (formatting-row (stream)
-        (format-place-cells stream object 'reader-place 'hash-table-count
+        (format-place-cells stream object 'deep-reader-place 'hash-table-count
                             :label "Count" :object-style :hash-table-count)
-        (format-place-cells stream object 'reader-place 'hash-table-size
+        (format-place-cells stream object 'deep-reader-place 'hash-table-size
                             :label "Size" :object-style :hash-table-size))
       (formatting-row (stream)
-        (format-place-cells stream object 'reader-place 'hash-table-rehash-size
+        (format-place-cells stream object 'deep-reader-place 'hash-table-rehash-size
                             :label "Rehash Size"
                             :object-style :hash-table-rehash-size)
-        (format-place-cells stream object 'reader-place 'hash-table-rehash-threshold
+        (format-place-cells stream object 'deep-reader-place 'hash-table-rehash-threshold
                             :label "Rehash Threshold"
                             :object-style :hash-table-rehash-threshold))))
 
diff --git a/Apps/Clouseau/src/objects/list.lisp b/Apps/Clouseau/src/objects/list.lisp
index 66238378..e8c0cbc4 100644
--- a/Apps/Clouseau/src/objects/list.lisp
+++ b/Apps/Clouseau/src/objects/list.lisp
@@ -2,13 +2,12 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
 ;;; Places, inspection methods and commands for cons cells and lists
 ;;; of different shapes.
-;;;
 
 (cl:in-package #:clouseau)
 
diff --git a/Apps/Clouseau/src/objects/package.lisp b/Apps/Clouseau/src/objects/package.lisp
index ee224f9a..59e949ef 100644
--- a/Apps/Clouseau/src/objects/package.lisp
+++ b/Apps/Clouseau/src/objects/package.lisp
@@ -14,7 +14,7 @@
 
 ;;; `package-data-place-mixin'
 
-(defclass package-data-place-mixin ()
+(defclass package-data-place-mixin (read-only-descendants-mixin)
   ())
 
 (defmethod supportsp :around ((place     package-data-place-mixin)
diff --git a/Apps/Clouseau/src/objects/symbol.lisp b/Apps/Clouseau/src/objects/symbol.lisp
index b7baa505..3404df74 100644
--- a/Apps/Clouseau/src/objects/symbol.lisp
+++ b/Apps/Clouseau/src/objects/symbol.lisp
@@ -165,7 +165,7 @@
                                        (stream t))
   (formatting-table (stream)
     (formatting-row (stream)
-      (format-place-cells stream object 'reader-place 'symbol-name
+      (format-place-cells stream object 'deep-reader-place 'symbol-name
                           :label "Name")
       (format-place-cells stream object 'symbol-package-place nil
                           :label "Package"))
diff --git a/Apps/Clouseau/src/place.lisp b/Apps/Clouseau/src/place.lisp
index 4c3bb17c..0a47629f 100644
--- a/Apps/Clouseau/src/place.lisp
+++ b/Apps/Clouseau/src/place.lisp
@@ -2,13 +2,12 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
 ;;; Basic classes implementing the place protocol in different
 ;;; ways. Intended as superclasses for specific place classes.
-;;;
 
 (cl:in-package #:clouseau)
 
@@ -62,9 +61,28 @@
         existing
         (setf (state place) (funcall thunk)))))
 
+(defmethod supportsp ((place     basic-place)
+                      (operation (eql 'modify-descendants)))
+  (if-let ((parent (parent place)))
+    (supportsp parent 'modify-descendants)
+    t))
+
+(defmethod supportsp :around ((place basic-place) (operation (eql 'setf)))
+  (and (call-next-method)
+       (if-let ((parent (parent place)))
+         (supportsp parent 'modify-descendants)
+         t)))
+
 (defmethod supportsp ((place basic-place) (operation (eql 'setf)))
   t)
 
+(defmethod supportsp :around ((place     basic-place)
+                              (operation (eql 'remove-value)))
+  (and (call-next-method)
+       (if-let ((parent (parent place)))
+         (supportsp parent 'modify-descendants)
+         t)))
+
 (defmethod supportsp ((place basic-place) (operation (eql 'remove-value)))
   nil)
 
@@ -78,6 +96,15 @@
   (when-let ((parent (parent place)))
     (note-changed parent)))
 
+;;; `read-only-descendants-mixin'
+
+(defclass read-only-descendants-mixin ()
+  ())
+
+(defmethod supportsp ((place     read-only-descendants-mixin)
+                      (operation (eql 'modify-descendants)))
+  nil)
+
 ;;; `read-only-place'
 
 (defclass read-only-place (basic-place)
@@ -86,6 +113,12 @@
 (defmethod supportsp ((place read-only-place) (operation (eql 'setf)))
   nil)
 
+;;; `deep-read-only-place'
+
+(defclass deep-read-only-place (read-only-descendants-mixin
+                                read-only-place)
+  ())
+
 ;;; `sequence-element-place'
 
 (defclass sequence-element-place (basic-place)
@@ -125,8 +158,12 @@
 
 ;;; `reader-place'
 
-(defclass reader-place (function-backed-place
-                        read-only-place)
+(defclass reader-place (read-only-place
+                        function-backed-place)
+  ())
+
+(defclass deep-reader-place (deep-read-only-place
+                             function-backed-place)
   ())
 
 ;;; `accessor-place'
@@ -142,9 +179,17 @@
 ;;; A place that is in some way computed or derived and not backed by
 ;;; a concrete location such as an instance slot or array element.
 
-(defclass pseudo-place (read-only-place)
+(defclass pseudo-place-mixin ()
   ((%cell :reader value)))
 
+(defclass pseudo-place (read-only-place
+                        pseudo-place-mixin)
+  ())
+
+(defclass deep-pseudo-place (deep-read-only-place
+                             pseudo-place-mixin)
+  ())
+
 ;;; `root-place'
 
 (defclass root-place (basic-place)