Add regex engine and persistent data structures

cl-cc-runtime.asd

@@ -35,6 +35,8 @@ structured logging, process execution and JSON rather than reimplementing them."
   :components
   ;; src/ is flat and every defpackage lives in src/package.lisp.
   ((:file "package")
+   (:file "regex")
+   (:file "persistent")
    (:file "runtime-region")
    (:file "runtime")
    (:file "runtime-conditions")
@@ -233,7 +235,8 @@ structured logging, process execution and JSON rather than reimplementing them."
    (:file "async-test")
    (:file "portable-test")
    (:file "gc-workers-test")
-   (:file "gc-major-sweep-incremental-test"))
+   (:file "gc-major-sweep-incremental-test")
+   (:file "regex-persistent-test"))
   ;; Not HOST-KIT:SYMBOL-CALL: a .asd is read before :depends-on is ever
   ;; consulted, so a CL-HOST-KIT-prefixed token here would be a read-time
   ;; PACKAGE-DOES-NOT-EXIST error regardless of what the system depends on.

src/package.lisp

@@ -138,6 +138,14 @@
     #:rt-dispatch-restart
      ;; Misc
       #:rt-boundp #:rt-fboundp #:rt-makunbound
+      ;; Regular expressions
+      #:rt-regex #:rt-regex-p #:rt-regex-compile #:rt-regex-match-p #:rt-regex-search
+      ;; Persistent data structures
+      #:rt-persistent-vector #:rt-persistent-vector-p
+      #:rt-persistent-vector-length #:rt-persistent-vector-ref
+      #:rt-persistent-vector-assoc #:rt-persistent-vector-conj
+      #:rt-persistent-map #:rt-persistent-map-p
+      #:rt-persistent-map-assoc #:rt-persistent-map-get
       ;; C embedding API (FR-812)
       #:cl-cc-state #:cl-cc-state-p #:make-cl-cc-state
       #:cl-cc-state-id #:cl-cc-state-vm #:cl-cc-state-package

src/persistent.lisp

@@ -0,0 +1,68 @@
+;;;; persistent.lisp -- immutable values with structural sharing.
+
+(in-package #:cl-cc/runtime)
+
+(defstruct (rt-persistent-vector (:constructor %make-rt-pvector (chunks count)))
+  chunks count)
+
+(defparameter +rt-pvector-chunk-size+ 32)
+
+(defun rt-persistent-vector (&rest values)
+  (let ((chunks (make-array (ceiling (length values) +rt-pvector-chunk-size+) :initial-element nil)))
+    (loop for value in values for i from 0
+          do (let ((chunk-index (floor i +rt-pvector-chunk-size+)))
+               (unless (aref chunks chunk-index) (setf (aref chunks chunk-index) (make-array +rt-pvector-chunk-size+)))
+               (setf (aref (aref chunks chunk-index) (mod i +rt-pvector-chunk-size+)) value)))
+    (%make-rt-pvector chunks (length values))))
+
+(defun rt-persistent-vector-length (vector) (rt-persistent-vector-count vector))
+(defun rt-persistent-vector-ref (vector index)
+  (check-type index (integer 0))
+  (when (>= index (rt-persistent-vector-count vector)) (error "Index ~D is out of bounds" index))
+  (aref (aref (rt-persistent-vector-chunks vector) (floor index +rt-pvector-chunk-size+))
+        (mod index +rt-pvector-chunk-size+)))
+
+(defun rt-persistent-vector-assoc (vector index value)
+  (check-type index (integer 0))
+  (when (>= index (rt-persistent-vector-count vector)) (error "Index ~D is out of bounds" index))
+  (let* ((chunk-index (floor index +rt-pvector-chunk-size+))
+         (chunks (copy-seq (rt-persistent-vector-chunks vector)))
+         (chunk (copy-seq (aref chunks chunk-index))))
+    (setf (aref chunk (mod index +rt-pvector-chunk-size+)) value
+          (aref chunks chunk-index) chunk)
+    (%make-rt-pvector chunks (rt-persistent-vector-count vector))))
+
+(defun rt-persistent-vector-conj (vector value)
+  (let* ((count (rt-persistent-vector-count vector))
+         (chunks (copy-seq (rt-persistent-vector-chunks vector)))
+         (chunk-index (floor count +rt-pvector-chunk-size+)))
+    (when (or (= count 0) (= (mod count +rt-pvector-chunk-size+) 0))
+      (setf chunks (adjust-array chunks (1+ chunk-index) :initial-element nil)))
+    (let ((chunk (if (aref chunks chunk-index)
+                     (copy-seq (aref chunks chunk-index))
+                     (make-array +rt-pvector-chunk-size+))))
+      (setf (aref chunk (mod count +rt-pvector-chunk-size+)) value
+            (aref chunks chunk-index) chunk)
+      (%make-rt-pvector chunks (1+ count)))))
+
+(defstruct (rt-persistent-map (:constructor %make-rt-pmap (root test))) root test)
+(defstruct (rt-pmap-node (:constructor %make-rt-pmap-node (key value left right))) key value left right)
+
+(defun rt-persistent-map (&key (test #'equal)) (%make-rt-pmap nil test))
+(defun %rt-pmap-assoc (node key value test)
+  (if (null node) (%make-rt-pmap-node key value nil nil)
+      (cond ((funcall test key (rt-pmap-node-key node))
+             (%make-rt-pmap-node key value (rt-pmap-node-left node) (rt-pmap-node-right node)))
+            ((string< (prin1-to-string key) (prin1-to-string (rt-pmap-node-key node)))
+             (%make-rt-pmap-node (rt-pmap-node-key node) (rt-pmap-node-value node)
+                                 (%rt-pmap-assoc (rt-pmap-node-left node) key value test) (rt-pmap-node-right node)))
+            (t (%make-rt-pmap-node (rt-pmap-node-key node) (rt-pmap-node-value node)
+                                   (rt-pmap-node-left node) (%rt-pmap-assoc (rt-pmap-node-right node) key value test))))))
+(defun rt-persistent-map-assoc (map key value)
+  (%make-rt-pmap (%rt-pmap-assoc (rt-persistent-map-root map) key value (rt-persistent-map-test map))
+                 (rt-persistent-map-test map)))
+(defun rt-persistent-map-get (map key &optional default)
+  (loop for node = (rt-persistent-map-root map) then (if (string< (prin1-to-string key) (prin1-to-string (rt-pmap-node-key node)))
+                                                         (rt-pmap-node-left node) (rt-pmap-node-right node))
+        while node do (when (funcall (rt-persistent-map-test map) key (rt-pmap-node-key node)) (return (rt-pmap-node-value node)))
+        finally (return default)))

src/regex.lisp

@@ -0,0 +1,116 @@
+;;;; regex.lisp -- a small, dependency-free regular expression engine.
+
+(in-package #:cl-cc/runtime)
+
+(defstruct (rt-regex (:constructor %make-rt-regex (pattern expression)))
+  pattern expression)
+
+(defun %regex-error (pattern position format-control &rest args)
+  (error "Invalid regular expression ~S at ~D: ~?" pattern position format-control args))
+
+(defun rt-regex-compile (pattern)
+  "Compile PATTERN. Supports literals, ., [], ^, $, grouping, |, *, + and ?."
+  (check-type pattern string)
+  (let ((i 0) (n (length pattern)))
+    (labels
+        ((peek () (and (< i n) (char pattern i)))
+         (take () (prog1 (peek) (incf i)))
+         (parse-atom ()
+           (let ((c (take)))
+             (unless c (%regex-error pattern i "expected an atom"))
+             (case c
+               (#\( (let ((e (expr)))
+                       (unless (eql (take) #\))
+                         (%regex-error pattern i "missing )"))
+                       e))
+               (#\. '(:any))
+               (#\^ '(:bol))
+               (#\$ '(:eol))
+               (#\[ (let ((negated (when (eql (peek) #\^) (take) t))
+                          (items nil) (closed nil))
+                      (loop while (peek)
+                            do (if (eql (peek) #\])
+                                   (progn (take) (setf closed t) (return))
+                                   (let ((first (if (eql (peek) #\\) (progn (take) (or (take) #\\)) (take))))
+                                     (if (eql (peek) #\-)
+                                         (progn (take)
+                                                (let ((last (if (eql (peek) #\\) (progn (take) (or (take) #\\)) (take))))
+                                                  (unless (and last (char<= first last))
+                                                    (%regex-error pattern i "invalid character range"))
+                                                  (push (list :range first last) items)))
+                                         (push (list :char first) items)))))
+                      (unless closed (%regex-error pattern i "missing ]"))
+                      (list :class negated (nreverse items))))
+               (#\\ (let ((e (take)))
+                       (unless e (%regex-error pattern i "trailing escape"))
+                       (case e
+                         (#\d '(:class nil ((:range #\0 #\9))))
+                         (#\D '(:class t ((:range #\0 #\9))))
+                         (#\w '(:class nil ((:range #\a #\z) (:range #\A #\Z) (:range #\0 #\9) (:char #\_))))
+                         (#\s '(:class nil ((:char #\Space) (:char #\Tab) (:char #\Newline) (:char #\Return))))
+                         (otherwise (list :char e)))))
+               (otherwise (list :char c)))))
+         (piece ()
+           (let ((a (parse-atom)))
+             (case (peek)
+               (#\* (take) (list :star a))
+               (#\+ (take) (list :plus a))
+               (#\? (take) (list :opt a))
+               (otherwise a))))
+         (seq ()
+           (let ((parts nil))
+             (loop while (and (peek) (not (member (peek) '(#\) #\|))))
+                   do (push (piece) parts))
+             (if parts (cons :seq (nreverse parts)) '(:empty))))
+         (expr ()
+           (let ((left (seq)))
+             (if (eql (peek) #\|) (progn (take) (list :alt left (expr))) left))))
+      (let ((expression (expr)))
+        (when (peek) (%regex-error pattern i "unexpected character ~C" (peek)))
+        (%make-rt-regex pattern expression)))))
+
+(defun %regex-class-member-p (char node)
+  (let ((member (some (lambda (item)
+                        (case (first item)
+                          (:char (char= char (second item)))
+                          (:range (char<= (second item) char (third item)))))
+                      (third node))))
+    (if (second node) (not member) member)))
+
+(defun %regex-match-node (node string position end)
+  (case (first node)
+    (:empty (list position))
+    (:char (and (< position end) (char= (second node) (char string position)) (list (1+ position))))
+    (:any (and (< position end) (list (1+ position))))
+    (:class (and (< position end) (%regex-class-member-p (char string position) node) (list (1+ position))))
+    (:bol (and (= position 0) (list position)))
+    (:eol (and (= position end) (list position)))
+    (:seq (reduce (lambda (positions child)
+                    (remove-duplicates (mapcan (lambda (p) (%regex-match-node child string p end)) positions)))
+                  (rest node) :initial-value (list position)))
+    (:alt (remove-duplicates (nconc (%regex-match-node (second node) string position end)
+                                   (%regex-match-node (third node) string position end))))
+    ((:star :plus :opt)
+     (let* ((minimum (if (eql (first node) :plus) 1 0))
+            (results (if (zerop minimum) (list position) nil))
+            (frontier (list position)))
+       (dotimes (ignored (if (eql (first node) :opt) 1 most-positive-fixnum))
+         (let ((next (remove position (remove-duplicates
+                                       (mapcan (lambda (p) (%regex-match-node (second node) string p end)) frontier)))))
+           (unless next (return))
+           (setf results (nconc results next) frontier next)))
+       (if (and (eql (first node) :plus) (not results)) nil results)))))
+
+(defun rt-regex-match-p (regex string &key (start 0) end)
+  "Return true when REGEX matches STRING from START through END."
+  (let ((r (if (typep regex 'rt-regex) regex (rt-regex-compile regex)))
+        (limit (or end (length string))))
+    (not (null (member limit (%regex-match-node (rt-regex-expression r) string start limit))))))
+
+(defun rt-regex-search (regex string &key (start 0) end)
+  "Return (start . end) for the first match, or NIL."
+  (let ((r (if (typep regex 'rt-regex) regex (rt-regex-compile regex)))
+        (limit (or end (length string))))
+    (loop for position from start to limit
+          for finishes = (%regex-match-node (rt-regex-expression r) string position limit)
+          when finishes do (return (cons position (apply #'max finishes))))))

t/regex-persistent-test.lisp

@@ -0,0 +1,34 @@
+;;;; Tests for the dependency-free regex and persistent data structure modules.
+(in-package :cl-cc-runtime/test)
+
+(describe "regular expressions"
+  (it "matches literals and concatenation"
+    (expect (rt-regex-match-p "ab" "ab") :to-be-truthy)
+    (expect (rt-regex-match-p "ab" "ac") :to-be-null))
+  (it "supports alternation and repetition"
+    (expect (rt-regex-match-p "(cat|dog)s?" "dogs") :to-be-truthy)
+    (expect (rt-regex-match-p "a+b*" "aaabbb") :to-be-truthy)
+    (expect (rt-regex-match-p "a+b*" "bbb") :to-be-null))
+  (it "supports classes, escapes, anchors, and search"
+    (expect (rt-regex-match-p "^[a-z]+@[a-z]+\\.com$" "a@b.com") :to-be-truthy)
+    (expect (rt-regex-match-p "^[^0-9]+$" "abc") :to-be-truthy)
+    (expect (rt-regex-search "cat" "a cat nap") :to-equal '(2 . 5))
+    (expect (rt-regex-search "a+" "aaa") :to-equal '(0 . 3))))
+
+(describe "persistent data structures"
+  (it "keeps vector versions independent"
+    (let* ((old (rt-persistent-vector 1 2))
+           (new (rt-persistent-vector-assoc old 0 9))
+           (grown (rt-persistent-vector-conj new 3)))
+      (expect (rt-persistent-vector-ref old 0) :to-be 1)
+      (expect (rt-persistent-vector-ref new 0) :to-be 9)
+      (expect (rt-persistent-vector-length grown) :to-be 3)
+      (expect (rt-persistent-vector-ref grown 2) :to-be 3)))
+  (it "shares map versions without mutation"
+    (let* ((empty (rt-persistent-map))
+           (one (rt-persistent-map-assoc empty :a 1))
+           (two (rt-persistent-map-assoc one :b 2)))
+      (expect (rt-persistent-map-get empty :a :missing) :to-be :missing)
+      (expect (rt-persistent-map-get one :a) :to-be 1)
+      (expect (rt-persistent-map-get one :b :missing) :to-be :missing)
+      (expect (rt-persistent-map-get two :b) :to-be 2))))