From e895be217c3be6769708da17c9ae87cb22db040e Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 6 Oct 2019 22:41:42 +0100
Subject: [PATCH] src/method-impl.lisp, etc.: Add a `readonly' message
 property.

If you have a `const' instance, it's useful to be able to send it
messages, so add a facility for marking messages as not modifying their
receivers.
---
 doc/SYMBOLS              | 3 +++
 doc/meta.tex             | 4 +++-
 doc/syntax.tex           | 3 +++
 src/class-make-impl.lisp | 6 ++++--
 src/classes.lisp         | 9 ++++++++-
 src/method-impl.lisp     | 8 ++++++--
 src/method-proto.lisp    | 2 +-
 7 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index b170827..7e18dcd 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -428,6 +428,7 @@ classes.lisp
   sod-message                                   class
   sod-message-class                             generic
   sod-message-name                              generic
+  sod-message-readonly-p                        generic
   sod-message-type                              generic
   sod-method                                    class
   sod-method-body                               generic
@@ -1731,6 +1732,8 @@ sod-message-method-class
   sod-message sod-class t
 sod-message-name
   sod-message
+sod-message-readonly-p
+  sod-message
 sod-message-receiver-type
   sod-message sod-class
 sod-message-type
diff --git a/doc/meta.tex b/doc/meta.tex
index dbbf2d6..67e77b2 100644
--- a/doc/meta.tex
+++ b/doc/meta.tex
@@ -216,13 +216,15 @@
                                         \&key :location}}
 \end{describe*}
 
-\begin{describe}{cls}{sod-message () \&key :name :location :class :type}
+\begin{describe}{cls}
+    {sod-message () \&key :name :location :readonly :class :type}
 \end{describe}
 
 \begin{describe*}
     {\dhead{gf}{sod-message-name @<message> @> @<string>}
      \dhead{meth}{sod-message}
        {file-location (@<message> sod-message) @> @<floc>}
+     \dhead{gf}{sod-message-readonly-p @<message> @> @<generalized-boolean>}
      \dhead{gf}{sod-message-class @<message> @> @<class>}
      \dhead{gf}{sod-message-type @<message> @> @<c-type>}}
 \end{describe*}
diff --git a/doc/syntax.tex b/doc/syntax.tex
index dd6a5f5..72329a4 100644
--- a/doc/syntax.tex
+++ b/doc/syntax.tex
@@ -903,6 +903,9 @@ Properties:
 \begin{description}
 \item[@|message_class|] A symbol naming the Lisp class to use to represent
   the message.
+\item[@|readonly|] A boolean indicating whether the message guarantees not to
+  modify its receiver.  If this is true, the receiver will be declared
+  @"const".
 \item[@|combination|] A keyword naming the aggregating method combination to
   use.
 \item[@|most_specific|] A keyword, either @`first' or @`last', according to
diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index b96d830..1da8bac 100644
--- a/src/class-make-impl.lisp
+++ b/src/class-make-impl.lisp
@@ -237,9 +237,11 @@
 
 (defmethod shared-initialize :after
     ((message sod-message) slot-names &key pset)
-  (declare (ignore slot-names pset))
   (with-slots ((type %type)) message
-    (check-message-type message type)))
+    (check-message-type message type))
+  (default-slot-from-property (message 'readonlyp slot-names)
+      (pset :readonly :boolean)
+    nil))
 
 (defmethod check-message-type ((message sod-message) (type c-function-type))
   nil)
diff --git a/src/classes.lisp b/src/classes.lisp
index 678d4a5..69df4d1 100644
--- a/src/classes.lisp
+++ b/src/classes.lisp
@@ -366,11 +366,14 @@
 ;;;--------------------------------------------------------------------------
 ;;; Messages and methods.
 
-(export '(sod-message sod-message-name sod-message-class sod-message-type))
+(export '(sod-message sod-message-name sod-message-readonly-p
+	  sod-message-class sod-message-type))
 (defclass sod-message ()
   ((name :initarg :name :type string :reader sod-message-name)
    (location :initarg :location :initform (file-location nil)
 	     :type file-location :reader file-location)
+   (readonlyp :initarg :readonly :initform nil :type t
+	      :reader sod-message-readonly-p)
    (%class :initarg :class :type sod-class :reader sod-message-class)
    (%type :initarg :type :type c-function-type :reader sod-message-type))
   (:documentation
@@ -403,6 +406,10 @@
      * The `location' states where in the user's source the slot was defined.
        It gets used in error messages.
 
+     * The `readonly' flag indicates whether the message receiver can modify
+       itself in response to this message.  If set, the receiver will be
+       declared `const'.
+
      * The `class' states which class defined the message.
 
      * The `type' is a function type describing the message's arguments and
diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index be33ecd..c1e1b24 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -62,7 +62,8 @@
 
 (defmethod sod-message-receiver-type ((message sod-message)
 				      (class sod-class))
-  (c-type (* (class class))))
+  (c-type (* (class class
+		    (and (sod-message-readonly-p message) :const)))))
 
 (export 'simple-message)
 (defclass simple-message (basic-message)
@@ -684,7 +685,10 @@
 
 	 ;; Effective method function details.
 	 (emf-name (effective-method-function-name method))
-	 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
+	 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)
+					  (and (sod-message-readonly-p
+						message)
+					       :const)))))
 	 (emf-type (c-type (fun (lisp return-type)
 				("sod__obj" (lisp ilayout-type))
 				. entry-args))))
diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index ed15ff2..e72044e 100644
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -54,7 +54,7 @@
   (:documentation
    "Return the type of the `me' argument in a MESSAGE received by CLASS.
 
-   Typically this will just be `CLASS *'."))
+   Typically this will just be `CLASS *' or `const CLASS *'."))
 
 (export 'sod-message-applicable-methods)
 (defgeneric sod-message-applicable-methods (message class)
-- 
2.11.0

