A common lisp subst variant that can traverse defstructs

Question

I am using SBCL and I don't mind a compiler-specific solution. I have form that involves some structs and I would like to walk and modify some sub-forms but subst can't see behind structs:

CL-USER> (defstruct my-struct slot-1 slot-2)
MY-STRUCT
CL-USER> (make-my-struct :slot-1 'a :slot-2 'b)
#S(MY-STRUCT :SLOT-1 A :SLOT-2 B)
CL-USER> (subst 'b1 'b (make-my-struct :slot-1 'a :slot-2 'b))
#S(MY-STRUCT :SLOT-1 A :SLOT-2 B)

Is there a way to make a general subst that can traverse all lisp-native structures?

Answer 1

For sbcl, something like this might work.

(use-package :sb-mop)

(defun search-and-replace (obj slot-old-value slot-new-value)
  (let ((slots (mapcar #'slot-definition-name (class-direct-slots (class-of obj)))))
    (dolist (s slots obj)
      (when (eql slot-old-value (slot-value obj s))
        (setf (slot-value obj s) slot-new-value)))))

This is assuming a lot of things, if you want to traverse into the value of slots, or traverse non-class values, it would need work.

Answer 2

As rajashekar's answer says: you can't do this portably. By making some use of the CLOS MOP you can do it for objects which are subclasses of standard-object. You might also be able to do it for instances of some things defined by defstruct, but this is absolutely not portable even insofar as the MOP is portable: there is no reason why slot-value &c should work on instances of classes defined by defstruct.

However, even where the implementation does allow this as an extension, doing this is generally extremely undesirable. It's undesirable because such a function will descend into arbitrary objects and not just those you have defined. If your tree contains objects defined by some library you are using it will walk into them. If it contains, for instance, streams, it may well walk into them. And who knows what it will find there, and who knows what damage it will do?

Outside of things like implementing debuggers or garbage collectors, you don't want something which will walk into and, worse, mutate arbitrary objects.

Far better to define your own function and teach it how to walk into the objects you define. For instance:

(declaim (inline nreplace))

(defun nreplace (new old tree &key key test test-not)
  (nreplace-loop tree new old key test test-not))

(defgeneric nreplace-loop (tree new old key test test-not)
  (:method-combination progn)           ;run all methods for an object
  (:method progn (tree new old key test test-not)
   (declare (ignore tree new old key test test-not)))
  (:method :around (tree new old key test test-not)
   (if (nreplace-matches old tree key test test-not)
       new
     (call-next-method))
   tree))

(defun nreplace-matches (in thing key test test-not)
  (let ((it (if key (funcall key in) in)))
    (cond
     ((and test test-not)
      (error "huh?"))
     (test
      (funcall test thing it))
     (test-not
      (not (funcall test-not thing it)))
     (t
      (eql thing it)))))

(defmethod nreplace-loop progn ((tree cons) new old key test test-not)
  (if (nreplace-matches old tree key test test-not)
      new
    (progn
      (if (nreplace-matches (car tree) old key test test-not)
          (setf (car tree) new)
        (nreplace-loop (car tree) new old key test test-not))
      (if (nreplace-matches (cdr tree) old key test test-not)
          (setf (cdr tree) new)
        (nreplace-loop (cdr tree) new old key test test-not)))))

Now nreplace (if I've got it right, which is not certain) knows how to do what subst can do. But we can teach it to deal with any object by defining methods.

In fact the obvious way to do this is to write a macro which knows how to write the methods for you for objects with a number of accessors:

(defmacro define-nreplace-accessor-replacer (classname &body accessors)
  `(defmethod nreplace-loop progn ((tree ,classname) new old key test test-not)
     ,@(mapcar (lambda (accessor)
                 `(let ((it (,accessor tree)))
                    (if (nreplace-matches it old key test test-not)
                        (setf (,accessor tree) new)
                      (nreplace-loop it new old key test test-not))))
               accessors)))

Now we can first of all replace the method for cons above:

(define-nreplace-accessor-replacer cons car cdr)

And if we define some structures:

(defstruct foo
  a
  b)

(define-nreplace-accessor-replacer foo foo-a foo-b)

(defstruct (bar (:include foo))
  c)

(define-nreplace-accessor-replacer bar bar-c)

And now

> (nreplace 2 1 (list (make-bar :a 1 :b 3 :c '(1 2 3))))
(#S(bar :a 2 :b 3 :c (2 2 3)))

If you really want to you can then define a macro which writes a suitable defstruct and the replacer for it, possibly adding slot options for 'should not be walked'.

Answer 3

If you can work with a more primitive structure representation, you could use the :type option to defstruct, making the resulting objects lists or vectors. This would mean that you can still use your defined accessors etc. to semantically work with those objects while also enabling treating them just as lists resp. vectors, but the runtime type checks don't work the same, of course.

Answer 4

As said in other answers it is not possible to have subst work like that. I would define tree-map, and can call it with a function that performs the search and replace:

(tree-map tree (lambda (u) (case u (b b1) (t u))))

tree-map

I implemented something similar at some point, using two generic functions split and join, which respectively decompose a value into parts and reassemble them into a value.

(defpackage :stack-overflow (:use :cl))
(in-package :stack-overflow)

(defgeneric split (object)
  (:documentation "Decompose an OBJECT into a list of parts")
  (:method (o) nil)
  (:method ((L list)) L))

(defgeneric join (prototype parts)
  (:documentation
   "Join list of PARTS according to the original PROTOTYPE object")
  (:method (p (_ null)) p)
  (:method ((p list) c) c))

(defun tree-map (tree function)
  (declare (optimize (debug 3)))
  (flet ((recurse (n) (tree-map n function)))
    (let ((parts (split tree)))
      (if parts
          (join tree (mapcar #'recurse parts))
          (funcall function tree)))))

This can also be defined as follows, if you want to call the user-provided function first on each node before splitting the result.

(defun tree-map (tree function)
  (declare (optimize (debug 3)))
  (flet ((tree-map (n) (tree-map n function)))
    (join tree (mapcar #'tree-map (split (funcall function tree))))))

Example

I set the level of debug to 3 to keep the original source code around. This may not work on all implementations but this only for the example:

(tree-map
 (function-lambda-expression #'tree-map)
 (let ((cache (make-hash-table)))
   (lambda (object)
     (typecase object
       (symbol
        (or #1=(gethash object cache)
            (setf #1# (gensym (string object)))))
       (t object)))))

This replaces all the symbols by a fresh uninterned one, while making sure the same symbol from the input always maps to the same symbol in the output:

(#:LAMBDA843 (#:TREE844 #:FUNCTION845) (#:DECLARE846 (#:TOP-LEVEL-FORM847))
 (#:DECLARE846 (#:OPTIMIZE848 (#:DEBUG849 3)))
 (#:BLOCK850 #:TREE-MAP851
  (#:FLET852 ((#:RECURSE853 (#:N854) (#:TREE-MAP851 #:N854 #:FUNCTION845)))
   (#:LET855 ((#:PARTS856 (#:SPLIT857 #:TREE844)))
    (#:IF858 #:PARTS856
     (#:JOIN859 #:TREE844
      (#:MAPCAR860 (#:FUNCTION845 #:RECURSE853) #:PARTS856))
     (#:FUNCALL861 #:FUNCTION845 #:TREE844))))))

Simple extension

Then you can define your own methods easily:

(defstruct point x y)

(defmethod split ((p point))
  (list (point-x p) (point-y p)))

(defmethod join ((p point) parts)
  (destructuring-bind (x y) parts
    (make-point :x x :y y)))

Subset of slots and mutation

The prototype argument is necessary to perform the dynamic dispatch on the object type, but also to recombine the parts in a meaningful way from the original object. Suppose you have the following class, where you want only a subset of the slots to be traversable:

(defclass task ()
  (name %thread %function))

(defmethod split ((o task))
  (list (slot-value o 'name)))

In fact, you want to be sure that the object retains its identity no matter what function you apply, so instead of copying the object, you can just return it modified.

(defmethod join ((o task) parts)
  (prog1 o
    (destructuring-bind (name) parts
      (setf (slot-value o 'name) name))))

Other ideas

• split and join could take an additional parameter, how, to further specialize on how the split is done (allowing for different views of a same object). For example you could define a method to split a symbol into a name, a package and a property list, etc.

• the use of an intermediate list of parts allocates some memory, the methods could be replaced by a single one that accepts a visitor function instead; for example, for the point:

    (defmethod visit ((o point) visitor)
      (make-point :x (funcall visitor (point-x o))
                  :y (funcall visitor (point-y o))))
  

  Here tree-map would give #'recurse as the visitor parameter. But split can be used separately from join to do another kind of processing than a map, so I found it more useful.