concrete-syntax-tree: Fix fixup processing of wrapper CSTs

Before this change, FIXUP did not recurse into DEFINITION-CST objects
which could lead to labeled objects remaining in the RAW slots of
ATOM-CST objects referenced through the TARGET slot of DEFINITION-CST
objects.

code/concrete-syntax-tree/labeled-objects.lisp

@@ -54,7 +54,12 @@
 (defclass reference-csts-mixin () ())
 
 (defmethod eclector.reader:fixup ((client cst-client)
-                                  (object wrapper-cst)
+                                  (object definition-cst)
+                                  seen-objects)
+  (eclector.reader:fixup client (target object) seen-objects))
+
+(defmethod eclector.reader:fixup ((client cst-client)
+                                  (object reference-cst)
                                   seen-objects)
   (declare (ignore seen-objects))) ; nothing to do
 

test/concrete-syntax-tree/client.lisp

@@ -11,14 +11,18 @@
 
 (test labeled-object-annotation
   "Test custom labeled object reference processing."
-  (is (equal* '(a #1=(b (:circular-reference #1#)
-                      c (:another-circular-reference #1#)
-                      d)
-                e (:ordinary-reference #1#) f)
-              (let ((eclector.base:*client*
-                      (make-instance 'annotating-cst-client)))
-                (cst:raw (eclector.concrete-syntax-tree:read-from-string
-                          "(A #1=(b #1# c #1# d) e #1# f)"))))))
+  (let* ((input "(A #1=(b #1# c #1# d) e #1# f)")
+         (client (make-instance 'annotating-cst-client))
+         (result (let ((eclector.base:*client* client))
+                   (eclector.concrete-syntax-tree:read-from-string input))))
+    (is-true (valid-cst-parse-result-p client result)
+             "~@<For input ~S, the result CST ~A is not valid.~@:>"
+             input result)
+    (is (equal* '(a #1=(b (:circular-reference #1#)
+                        c (:another-circular-reference #1#)
+                        d)
+                  e (:ordinary-reference #1#) f)
+                (cst:raw result)))))
 
 ;;; Test wrapper CST classes
 
@@ -40,9 +44,22 @@
           (*max-trials* 10000))
       (for-all ((expression (gen-labels-and-references)))
         (let* ((input (prin1-to-string expression))
-               (result (let ((eclector.base:*client*
-                               (make-instance 'wrapper-cst-client)))
+               (client (make-instance 'wrapper-cst-client))
+               (result (let ((eclector.base:*client* client))
                          (eclector.concrete-syntax-tree:read-from-string input))))
           (assert (equal* expression (read-from-string input)))
+          (is-true (valid-cst-parse-result-p client result)
+                   "~@<For input ~S, the result CST ~A is not valid.~@:>"
+                   input result)
           (is (equal* expression (cst:raw result)))
           (is (equal* expression (raw* result))))))))
+
+(test wrapper-labeled-object-csts/missed-labeled-object
+  "Check that no labeled objects remain in the parse result tree."
+  (let* ((input "#1=(#2=(#1#))")
+         (client (make-instance 'wrapper-cst-client))
+         (result (let ((eclector.base:*client* client))
+                   (eclector.concrete-syntax-tree:read-from-string input))))
+    (is (valid-cst-parse-result-p client result)
+        "~@<For input ~S, the result CST ~A is not valid.~@:>"
+        input result)))

test/concrete-syntax-tree/read-code.lisp

@@ -12,7 +12,10 @@
                 ;; Do not use (is (typep ...)) so the number of checks does
                 ;; not vary with source code changes.
                 (unless (typep parse-result '#1=concrete-syntax-tree:cst)
-                  (fail "~@<~S is not of type ~S.~@:>" parse-result '#1#)))
+                  (fail "~@<~S is not of type ~S.~@:>" parse-result '#1#))
+                (unless (valid-cst-parse-result-p client parse-result)
+                  (fail "~@<~S is not a valid CST parse result.~@:>"
+                        client parse-result)))
               (lambda (&rest args)
                 (let ((eclector.base:*client* client))
                   (apply #'eclector.concrete-syntax-tree:read args)))))))

test/concrete-syntax-tree/read.lisp

@@ -20,6 +20,8 @@
            (declare (ignore orphan-results))
            ;; CST result and its raw content.
            (is (typep result 'cst:cst))
+           (is-true (valid-cst-parse-result-p
+                     eclector.concrete-syntax-tree::*cst-client* result))
            (is-consistent-with-raw result)
            (let ((raw (cst:raw result)))
              (expect "raw result" (equal* expected-raw raw)))
@@ -60,6 +62,9 @@
           (t
            (multiple-value-bind (result orphan-results position) (do-it)
              (is (typep result 'cst:cst))
+             (is-true (valid-cst-parse-result-p
+                       eclector.concrete-syntax-tree::*cst-client* result))
+             (is-consistent-with-raw result)
              (let ((raw (cst:raw result)))
                (expect "raw results" (equal expected-result raw)))
              (expect "orphan results" (eq  '()               orphan-results))
@@ -88,6 +93,9 @@
           (t
            (multiple-value-bind (result position) (do-it)
              (is (typep result 'cst:cst))
+             (is-true (valid-cst-parse-result-p
+                       eclector.concrete-syntax-tree::*cst-client* result))
+             (is-consistent-with-raw result)
              (let ((raw (cst:raw result)))
                (expect "raw result" (equal expected-value raw)))
              (expect "position" (eql expected-position position))))))

test/concrete-syntax-tree/utilities.lisp

@@ -22,3 +22,21 @@
                        (rec cst-car)
                        (rec cst-cdr)))))))
       (rec cst))))
+
+(defun valid-cst-parse-result-p (client root-cst)
+  (let ((seen (make-hash-table :test #'eq)))
+    (labels ((rec (cst)
+               (cond ((gethash cst seen)
+                      t)
+                     (t
+                      (setf (gethash cst seen) t)
+                      (typecase cst
+                        (cst:atom-cst
+                         (not (eclector.reader:labeled-object-state
+                               client (cst:raw cst))))
+                        (cst:cons-cst
+                         (and (rec (cst:first cst))
+                              (rec (cst:rest cst))))
+                        (eclector.concrete-syntax-tree:wrapper-cst
+                         (rec (eclector.concrete-syntax-tree:target cst))))))))
+      (rec root-cst))))