Add a representation of the reader state with dependency tracking

code/analyzer.lisp

@@ -1,29 +1,88 @@
 (cl:in-package #:incrementalist)
 
+;;; Initial reader state
+
+(defun make-initial-reader-state
+    (&key (readtable                 eclector.reader:*readtable*)
+          (package                   "COMMON-LISP-USER")
+          (read-base                 10)
+          (read-default-float-format 'single-float)
+          (read-eval                 t)
+          (features                  *features*))
+  ;; Should be ordered roughly by access frequency.
+  `(;; Reader state aspects that do not correspond to standard
+    ;; variables.
+    (eclector.reader::*consing-dot-allowed-p* . nil)
+    (eclector.reader::*quasiquotation-state*  . (nil . nil))
+    (eclector.reader::*quasiquotation-depth*  . 0)
+    ;; Reader state aspect that correspond to standard variables.
+    (*readtable*                              . ,readtable)
+    (*read-suppress*                          . nil)
+    (*package*                                . ,package)
+    (*read-base*                              . ,read-base)
+    (*read-default-float-format*              . ,read-default-float-format)
+    (*read-eval*                              . ,read-eval)
+    (*features*                               . ,features)
+    ;; Labeled objects are not a reader state aspect from Eclector's
+    ;; point of view.
+    (labeled-objects                          . ())))
+
+(defun merge-initial-reader-states (delta-state base-state)
+  (if (eq delta-state base-state)
+      base-state
+      (loop :for (aspect . value) :in base-state
+            :for new-cell = (assoc aspect delta-state)
+            :collect (cons aspect (if (not (null new-cell))
+                                      (cdr new-cell)
+                                      value)))))
+
 (defclass analyzer (buffer-stream)
-  ((%buffer :initarg :buffer
-            :reader  buffer)
-   (%cache  :initarg :cache
-            :reader  cache))
+  ((%buffer               :initarg  :buffer
+                          :reader   buffer)
+   (%cache                :initarg  :cache
+                          :reader   cache)
+   ;; Specifies the reader state that should be used for reading the
+   ;; first toplevel expression of the buffer. The value is a list of
+   ;; `cell's.
+   (%initial-reader-state :type     #+incrementalist-debug dep:list-of-cells-for-distinct-aspects
+                                    #-incrementalist-debug list
+                          :reader   initial-reader-state))
   (:default-initargs
-   :buffer (alexandria:required-argument :buffer)
-   :lines  nil))
+   :buffer               (alexandria:required-argument :buffer)
+   :lines                nil
+   :initial-reader-state (make-initial-reader-state)))
 
-(defmethod shared-initialize :around ((instance   analyzer)
-                                      (slot-names t)
-                                      &rest args
-                                      &key (buffer nil buffer-supplied-p)
-                                           (cache  nil cache-supplied-p))
-  (cond ((not buffer-supplied-p)
-         (call-next-method))
-        (cache-supplied-p
-         (let ((lines (lines cache)))
-           (apply #'call-next-method instance slot-names :lines lines args)))
-        (t
-         (let* ((cache (make-instance 'cache :buffer buffer))
-                (lines (lines cache)))
-           (apply #'call-next-method instance slot-names
-                  :cache cache :lines lines args)))))
+(defmethod shared-initialize :around
+    ((instance   analyzer)
+     (slot-names t)
+     &rest args
+     &key (buffer               nil buffer-supplied-p)
+          (cache                nil cache-supplied-p)
+          (initial-reader-state nil initial-reader-state-supplied-p))
+  (prog1
+      (cond ((not buffer-supplied-p)
+             (call-next-method))
+            (cache-supplied-p
+             (let ((lines (lines cache)))
+               (apply #'call-next-method instance slot-names :lines lines
+                      args)))
+            (t
+             (let* ((cache (make-instance 'cache :buffer buffer))
+                    (lines (lines cache)))
+               (apply #'call-next-method instance slot-names
+                      :cache cache :lines lines args))))
+    ;; If supplied, use aspects from INITIAL-READER-STATE to add
+    ;; aspects to or change aspects in the default initial reader
+    ;; state.
+    (when initial-reader-state-supplied-p
+      (loop :for (aspect . value) :in (merge-initial-reader-states
+                                       initial-reader-state
+                                       (make-initial-reader-state))
+            :collect (dep:make-cell :global aspect value) :into cells
+            :finally (setf (slot-value instance '%initial-reader-state)
+                           cells)))))
+
+;;;
 
 (defmethod position< ((left basic-wad) (right analyzer))
   (%position< (start-line left)   (start-column left)
@@ -48,24 +107,46 @@
 ;;; stream position, then remove them.
 ;;;
 ;;; If we return a wad at all, it has the following properties:
-;;; 1. it is absolute
-;;  2. all its descendants are relative
-;;; 3. the absolute line start line number are up-to-date for the
-;;;    returned wad and all its descendants
+;;; 1. it is valid (`dep:validp' returns true)
+;;  2. all its descendants are valid
+;;; 3. it is absolute
+;;; 4. all its descendants are relative
+;;; 5. its absolute start line number is up-to-date
+;;; 6. the absolute start line numbers are up-to-date for all its
+;;;    descendants
 (defun cached-wad (analyzer)
+  ;; When a wad is removed here (due to being invalid or not matching
+  ;; the stream position of ANALYZER), the wad and its descendants are
+  ;; removed/detached from multiple data structures:
+  ;; 1. The wad is popped from the residue or suffix (The descendants
+  ;;    of the wad may still be on the residue or worklist)
+  ;; 2. The wad and its descendants are removed from user lists of any
+  ;;    cells
+  ;; 3. Any cells that are defined by the wad or its descendants
+  ;;    become invalid
   (let ((cache (cache analyzer)))
-    (macrolet ((skip (reader popper)
-                 `(progn
-                    (drain-result-list analyzer cache ,reader ,popper)
-                    (,reader cache))))
-      (let ((residue (skip residue pop-from-residue)))
-        (cond ((null residue)
-               (let ((suffix (skip suffix pop-from-suffix)))
-                 (if (and (not (null suffix))
-                          (position= (first suffix) analyzer))
-                     (compute-absolute-line-numbers (pop-from-suffix cache))
-                     nil)))
-              ((position= (first residue) analyzer)
-               (compute-absolute-line-numbers (first residue)))
-              (t
-               nil))))))
+    (macrolet
+        ((maybe-result (reader popper)
+           `(progn
+              (drain-result-list analyzer cache ,reader ,popper)
+              (let ((rest (,reader cache))
+                    wad validp)
+                (cond ((null rest)
+                       nil)
+                      ((not (position= (setf wad (first rest)) analyzer))
+                       nil)
+                      ((and (not (setf validp (dep:validp wad)))
+                            (not (dep:valid-for-state-p wad)))
+                       (detach-wad wad)
+                       (,popper cache)
+                       nil)
+                      (t
+                       (let ((wad (,popper cache)))
+                         (dbg:log :wad "Preparing wad for reuse ~A~%" wad)
+                         (when (not validp) ; not valid but valid for state
+                           (update-invalid-cells wad))
+                         (compute-absolute-line-numbers wad))))))))
+      (let ((residue-wad (maybe-result residue pop-from-residue)))
+        (if (not (null residue-wad))
+            residue-wad
+            (maybe-result suffix pop-from-suffix))))))

code/cache.lisp

@@ -12,49 +12,52 @@
 (defclass cache ()
   (;; This slot contains the Cluffer buffer that is being analyzed by
    ;; this cache instance.
-   (%buffer        :initarg  :buffer
-                   :reader   buffer)
+   (%buffer               :initarg  :buffer
+                          :reader   buffer)
    ;; The time stamp passed to and returned by the Cluffer update
    ;; protocol.
-   (%time-stamp    :accessor time-stamp
-                   :type     (or null alexandria:non-negative-integer)
-                   :initform nil)
+   (%time-stamp           :accessor time-stamp
+                          :type     (or null alexandria:non-negative-integer)
+                          :initform nil)
    ;; This slot contains a list that parallels the prefix and it
    ;; contains the width of the prefix starting with the first element
    ;; of the prefix.
-   (%lines         :reader   lines
-                   :initform (make-instance 'flx:standard-flexichain))
-   (%cluffer-lines :reader   cluffer-lines
-                   :initform (make-instance 'flx:standard-flexichain))
+   (%lines                :reader   lines
+                          :initform (make-instance 'flx:standard-flexichain))
+   (%cluffer-lines        :reader   cluffer-lines
+                          :initform (make-instance 'flx:standard-flexichain))
    ;; The prefix contains top-level wads in reverse order, so that the
    ;; last wad in the prefix is the first wad in the buffer.  Every
    ;; top-level wad in the prefix has an absolute line number.
-   (%prefix        :accessor prefix
-                   :type     list
-                   :initform '())
-   (%prefix-width  :accessor prefix-width
-                   :initform '())
+   (%prefix               :accessor prefix
+                          :type     list
+                          :initform '())
+   (%prefix-width         :accessor prefix-width
+                          :initform '())
    ;; The suffix contains top-level wads in the right order.  The
    ;; first top-level wad on the suffix has an absolute line number.
    ;; All the others have relative line numbers.
-   (%suffix        :accessor suffix
-                   :type     list
-                   :initform '())
+   (%suffix               :accessor suffix
+                          :type     list
+                          :initform '())
+   (%suffix-invalid-count :accessor suffix-invalid-count
+                          :type     alexandria:non-negative-integer
+                          :initform 0)
    ;; This slot contains a list that parallels the suffix and it
    ;; contains the width of the suffix starting with the first element
    ;; of the suffix.
-   (%suffix-width  :accessor suffix-width
-                   :initform '())
+   (%suffix-width         :accessor suffix-width
+                          :initform '())
    ;; The residue is normally empty.  The `scavenge' phase puts orphan
    ;; wads that are still valid on the residue, and these are used by
    ;; the `read-forms' phase to avoid reading characters when the
    ;; result is known.
-   (%residue       :accessor residue
-                   :type     list
-                   :initform '())
-   (%worklist      :accessor worklist
-                   :type     list
-                   :initform '()))
+   (%residue              :accessor residue
+                          :type     list
+                          :initform '())
+   (%worklist             :accessor worklist
+                          :type     list
+                          :initform '()))
   (:default-initargs
    :buffer (alexandria:required-argument :buffer)))
 
@@ -109,6 +112,25 @@
   (loop for line-number from first-line-number to last-line-number
         maximize (line-length cache line-number)))
 
+(defmethod (setf dep:invalid) :around ((new-value t) (wad wad))
+  ;; If WAD is top-level (that is, it does not have a parent) and the
+  ;; validity of WAD changes and WAD is on the suffix of the
+  ;; associated cache, adjust the `suffix-invalid-count' of the cache.
+  (if (null (parent wad))
+      (let ((old-value (dep:invalid wad)))
+        (flet ((maybe-adjust (amount)
+                 (let ((cache (cache wad))
+                       suffix)
+                   (when (or (relative-p wad)
+                             (eq wad (first (setf suffix (suffix cache)))))
+                     (incf (suffix-invalid-count cache) amount)))))
+          (cond ((and (null old-value) (not (null new-value)))
+                 (maybe-adjust 1))
+                ((and (not (null old-value)) (null new-value))
+                 (maybe-adjust -1))))
+        (call-next-method))
+      (call-next-method)))
+
 (defgeneric pop-from-suffix (cache)
   (:method ((cache cache))
     (let* ((old-suffix     (suffix cache))
@@ -117,6 +139,8 @@
            (new-suffix-top (first new-suffix)))
       (assert (not (null old-suffix)))
       (pop (suffix-width cache))
+      (unless (null (dep:invalid old-suffix-top))
+        (decf (suffix-invalid-count cache)))
       (setf (suffix cache) new-suffix)
       (unless (null new-suffix-top)
         (relative-to-absolute new-suffix-top (start-line old-suffix-top)))
@@ -142,6 +166,8 @@
              (first old-suffix-width)
              (max-line-length
               cache (1+ (end-line wad)) (1- (start-line old-suffix-top))))))
+      (unless (null (dep:invalid wad))
+        (incf (suffix-invalid-count cache)))
       (setf (suffix-width cache) (list* new-width old-suffix-width)
             (suffix cache)       new-suffix)
       (link-siblings (first (prefix cache)) wad)
@@ -182,12 +208,24 @@
 
 (defgeneric suffix-to-prefix (cache)
   (:method ((cache cache))
-    (let ((wad (compute-absolute-line-numbers (pop-from-suffix cache))))
+    (let ((wad (pop-from-suffix cache)))
+      ;; WAD has been taken from the suffix so
+      ;; 1) the absolute line numbers in WAD itself and its
+      ;;    descendants are potentially invalid.
+      ;; 2) the list of inherited cells in WAD is not populated
+      (compute-absolute-line-numbers wad)
+      (setf (dep:inherited wad) (dep:inheritable (first (prefix cache))))
       (push-to-prefix cache wad))))
 
 (defgeneric prefix-to-suffix (cache)
   (:method ((cache cache))
-    (push-to-suffix cache (pop-from-prefix cache))))
+    (let ((wad (pop-from-prefix cache)))
+      ;; During the time WAD will spend on the suffix, its list of
+      ;; inherited cells would not be kept up-to-date.  So we clear
+      ;; the slot here and recompute a new value when WAD is moved to
+      ;; the prefix.
+      (setf (dep:inherited wad) :invalid)
+      (push-to-suffix cache wad))))
 
 (defun pop-from-worklist (cache)
   (pop (worklist cache)))
@@ -208,7 +246,8 @@
          ;; Detach before popping because detaching may traverse the
          ;; ancestors of the wad and popping may sever the parent
          ;; link.
-         :do (,popper ,cache)))
+         :do (detach-wad (first remaining))
+             (,popper ,cache)))
 
 (defun finish-scavenge (cache)
   ;; Move entire worklist to residue
@@ -281,6 +320,7 @@
   (let ((wad (pop-from-worklist cache)))
     (if (line-is-inside-wad-p wad line-number)
         (let ((children (children wad)))
+          (detach-wad wad :recursive nil)
           (make-absolute children (start-line wad))
           (setf (worklist cache) (append children (worklist cache))))
         (push-to-residue cache wad))))

code/client.lisp

@@ -25,7 +25,12 @@
 ;;; Read-time evaluation
 
 (defmethod reader:evaluate-expression ((client client) (expression t))
-  1)
+  ;; HACK: we support setting `*read-base*' via
+  ;; #.(setf *read-base* ...) for testing
+  (multiple-value-bind (value valuep) (maybe-set-read-base client expression)
+    (if valuep
+        value
+        1)))
 
 ;;; Token interpretation
 
@@ -263,7 +268,8 @@
     ;; that is still on the residue or suffix without performing the
     ;; corresponding recursive `read-maybe-nothing' call. As a
     ;; workaround, consume any such wads here.
-    (cached-wad stream)
+    (alexandria:when-let ((cached (cached-wad stream)))
+      (detach-wad cached))
     ;; Separate CHILDREN into children of type `cst:cst' and "extra"
     ;; children. Extra children arise mainly due to comments and other
     ;; skipped input which are represented as `wad's which are not of