Merge pull request #5 from scymtym/master

Preparation for CST WADs, BUFFER-STREAM efficiency fixes

.github/workflows/publish-documentation.yml

@@ -22,8 +22,8 @@ jobs:
           cd documentation
           make
           mkdir -p build build/{pdf,info}
-          cp index.html        build/
-          cp *.png             build/
+          cp index.html          build/
+          cp *.png               build/
           cp incrementalist.html build/
           cp incrementalist.pdf  build/pdf/
           cp incrementalist.info build/info/
@@ -53,4 +53,4 @@ jobs:
     steps:
       - name: Deploy to GitHub Pages
         id: deployment
-        uses: actions/deploy-pages@v2
+        uses: actions/deploy-pages@v4

.github/workflows/test.yml

@@ -0,0 +1,33 @@
+name: test
+
+on: [push]
+
+jobs:
+
+  test:
+    runs-on: ubuntu-latest
+
+    steps:
+      - name: Prepare runner
+        run: |
+          DEBIAN_FRONTEND=noninteractive sudo apt-get -qq update \
+            && DEBIAN_FRONTEND=noninteractive sudo apt-get -qq --assume-yes install \
+                 sbcl
+
+      - uses: actions/checkout@v1
+
+      - name: Install quicklisp
+        run: |
+          wget https://beta.quicklisp.org/quicklisp.lisp
+          sbcl --noinform --disable-debugger        \
+            --load quicklisp.lisp                   \
+            --eval '(quicklisp-quickstart:install)' \
+            --quit
+
+      - name: Run tests
+        run: |
+          sbcl --noinform --disable-debugger                                                                                                \
+            --load "${HOME}/quicklisp/setup.lisp"                                                                                           \
+            --eval '(asdf:initialize-source-registry (quote (:source-registry (:directory "'"$(pwd)"'") :ignore-inherited-configuration)))' \
+            --eval '(ql:quickload "incrementalist/test")'                                                                                    \
+            --eval '(asdf:test-system "incrementalist")'

README.org

@@ -10,7 +10,7 @@
   The purpose of the Incrementalist library is incremental parsing of
   Common Lisp code that is contained in a [[https://github.com/robert-strandh/cluffer][Cluffer]] buffer into a syntax
   tree. The parsing is incremental in the sense that after a small
-  change in the buffer text, the syntax tree can be update with a
+  change in the buffer text, the syntax tree can be updated with a
   small amount of parsing work.
 
   *This library is under active development. Its ASDF system

code/analyzer.lisp

@@ -4,22 +4,17 @@
   ((%buffer :initarg :buffer :reader buffer)
    (%cache :initarg :cache :reader cache)))
 
-(defmethod print-object ((object analyzer) stream)
-  (print-unreadable-object (object stream :type t :identity t)
-    (format stream "~A,~A"
-            (current-line-number object) (current-item-number object))))
-
 (defmethod position< ((left basic-wad) (right analyzer))
-  (%position< (start-line left)           (start-column left)
-              (current-line-number right) (current-item-number right)))
+  (%position< (start-line left)   (start-column left)
+              (line-number right) (item-number right)))
 
 (defmethod position> ((left basic-wad) (right analyzer))
-  (%position> (start-line left)           (start-column left)
-              (current-line-number right) (current-item-number right)))
+  (%position> (start-line left)   (start-column left)
+              (line-number right) (item-number right)))
 
 (defmethod position= ((left basic-wad) (right analyzer))
-  (and (= (start-line left)   (current-line-number right))
-       (= (start-column left) (current-item-number right))))
+  (and (= (start-line left)   (line-number right))
+       (= (start-column left) (item-number right))))
 
 ;;; Check whether there is a cached wad with a start position that
 ;;; corresponds to the current stream position of ANALYZER, and if so,
@@ -47,5 +42,5 @@
                 nil))))))
 
 (defun advance-stream-to-beyond-wad (analyzer wad)
-  (setf (current-line-number analyzer) (end-line wad)
-        (current-item-number analyzer) (end-column wad)))
+  (setf (line-number analyzer) (end-line wad)
+        (item-number analyzer) (end-column wad)))

code/buffer-stream.lisp

@@ -1,71 +1,114 @@
 (cl:in-package #:incrementalist)
 
-(defgeneric eof-p (buffer-stream))
-
-(defgeneric next-position (lines line-number item-number))
-
-(defgeneric previous-position (lines line-number item-number))
-
-(defgeneric forward (buffer-stream))
+;;; A class for presenting a snapshot of the contents of a Cluffer
+;;; buffer a (character input) stream.
+;;;
+;;; The operations `cl:file-position' (reading and writing) are not
+;;; supported at the moment.
+;;;
+;;; An instance of this class stores the item sequences of the lines
+;;; of a Cluffer buffer in its `%lines' slot.  The other crucial piece
+;;; of state is current location which stored in the `%line-number'
+;;; and `%item-number' slots.  The remaining slots cache information
+;;; that would be too costly to compute or retrieve in every stream
+;;; operation.
+(defclass buffer-stream (gs:fundamental-character-input-stream)
+  ((%lines       :initarg  :lines
+                 :reader   lines)
+   ;; Current position
+   (%line-number :type     (or null alexandria:array-index)
+                 :accessor line-number
+                 :initform nil)
+   (%item-number :type     alexandria:array-index
+                 :accessor item-number)
+   ;; Cached line information
+   (%line-count  :accessor %line-count)
+   (%line        :accessor %line)
+   (%item-count  :accessor %item-count))
+  (:default-initargs
+   :lines (alexandria:required-argument :lines)))
 
-(defgeneric backward (buffer-stream))
+(declaim (inline update-lines-cache update-line-cache))
+(defun update-lines-cache (stream lines)
+  (setf (line-number stream) nil ; forces update of `%line', `%item-count'
+        (%line-count stream) (flx:nb-elements lines)))
 
-(defclass buffer-stream (gs:fundamental-character-input-stream)
-  ((%lines :initarg :lines :reader lines)
-   (%current-line-number :initform 0 :accessor current-line-number)
-   (%current-item-number :initform 0 :accessor current-item-number)))
+(defun update-line-cache (stream lines old-line-number new-line-number)
+  (unless (eql new-line-number old-line-number)
+    (let ((line (flx:element* lines new-line-number)))
+      (setf (%line       stream) line
+            (%item-count stream) (length line)))))
 
-(defmethod eof-p ((stream buffer-stream))
-  (let* ((lines (lines stream))
-         (last-line-number (1- (flx:nb-elements lines)))
-         (last-line (flx:element* lines last-line-number))
-         (last-line-length (length last-line)))
-    (and (= (current-line-number stream) last-line-number)
-         (= (current-item-number stream) last-line-length))))
+(defmethod shared-initialize :after ((instance   buffer-stream)
+                                     (slot-names t)
+                                     &key (lines nil lines-supplied-p))
+  (when lines-supplied-p
+    (update-lines-cache instance lines)))
 
-(defmethod next-position ((lines flx:flexichain) line-number item-number)
-  (if (= (length (flx:element* lines line-number)) item-number)
-      (values (1+ line-number) 0)
-      (values line-number (1+ item-number))))
+(defmethod (setf line-number) :around ((new-value integer)
+                                       (object    buffer-stream))
+  (let ((old-value (line-number object)))
+    (call-next-method)
+    (update-line-cache object (lines object) old-value new-value)))
 
-(defmethod previous-position ((lines flx:flexichain) line-number item-number)
-  (if (zerop item-number)
-      (values (1- line-number)
-              (length (flx:element* lines (1- line-number))))
-      (values line-number (1- item-number))))
+(defmethod print-object ((object buffer-stream) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (format stream "~:[N/A~;~:*~A~],~:[N/A~;~:*~A~]"
+            (line-number object)
+            (if (slot-boundp object '%item-number)
+                (item-number object)
+                nil))))
 
-(macrolet ((define (name position-method)
-             `(defmethod ,name ((stream buffer-stream))
-                (with-accessors ((lines lines)
-                                 (current-line-number current-line-number)
-                                 (current-item-number current-item-number))
-                    stream
-                  (setf (values current-line-number current-item-number)
-                        (,position-method lines current-line-number current-item-number))))))
-  (define forward  next-position)
-  (define backward previous-position))
+;;; Gray stream protocol
 
 (defmethod gs:stream-peek-char ((stream buffer-stream))
-  (if (eof-p stream)
-      :eof
-      (let* ((lines (lines stream))
-             (current-line-number (current-line-number stream))
-             (current-item-number (current-item-number stream))
-             (line (flx:element* lines current-line-number)))
-        (if (= (length line) current-item-number)
-            #\Newline
-            (aref line current-item-number)))))
+  (let* ((item-number   (item-number stream))
+         (end-of-line-p (= item-number (the alexandria:array-index
+                                            (%item-count stream)))))
+    (declare (type alexandria:array-index item-number))
+    (cond ((not end-of-line-p)
+           (let ((line (%line stream)))
+             (declare (type simple-string line))
+             (aref line item-number)))
+          ((= (the alexandria:array-index (line-number stream))
+              (1- (the alexandria:array-index (%line-count stream))))
+           :eof)
+          (t
+           #\Newline))))
 
 (defmethod gs:stream-read-char ((stream buffer-stream))
-  (let ((result (gs:stream-peek-char stream)))
-    (prog1
-        result
-      (unless (eq result :eof)
-        (forward stream)))))
+  (declare (optimize speed))
+  (let* (line-number
+         (item-number   (item-number stream))
+         (end-of-line-p (= item-number (the alexandria:array-index
+                                            (%item-count stream)))))
+    (declare (type alexandria:array-index item-number))
+    (cond ((not end-of-line-p)
+           (prog1
+               (let ((line (%line stream)))
+                 (declare (type simple-string line))
+                 (aref line item-number))
+             (setf (item-number stream) (1+ item-number))))
+          ((= (setf line-number (the alexandria:array-index (line-number stream)))
+              (1- (the alexandria:array-index (%line-count stream))))
+           :eof)
+          (t
+           (prog1
+               #\Newline
+             (setf (line-number stream) (1+ line-number) ; updates cache
+                   (item-number stream) 0))))))
 
-(defmethod gs:stream-unread-char ((stream buffer-stream) char)
-  (declare (ignore char))
-  (backward stream))
+(defmethod gs:stream-unread-char ((stream buffer-stream) (char t))
+  (let* (line-number
+         (item-number         (item-number stream))
+         (beginning-of-line-p (zerop item-number)))
+    (cond ((not beginning-of-line-p)
+           (setf (item-number stream) (1- item-number)))
+          ((zerop (setf line-number (line-number stream)))
+           (error "Attempt to unread a character at position 0"))
+          (t
+           (setf (line-number stream) (1- line-number) ; updates cache
+                 (item-number stream) (length (%line stream)))))))
 
 (defun compute-max-line-width (buffer-stream start-line end-line children)
   (let ((lines (lines buffer-stream)))