diff --git a/cl-cc-runtime.asd b/cl-cc-runtime.asd index fd0f931..fc22bc8 100644 --- a/cl-cc-runtime.asd +++ b/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. diff --git a/src/package.lisp b/src/package.lisp index 6711164..ece1964 100644 --- a/src/package.lisp +++ b/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 diff --git a/src/persistent.lisp b/src/persistent.lisp new file mode 100644 index 0000000..6065cfc --- /dev/null +++ b/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))) diff --git a/src/regex.lisp b/src/regex.lisp new file mode 100644 index 0000000..1268db9 --- /dev/null +++ b/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)))))) diff --git a/t/regex-persistent-test.lisp b/t/regex-persistent-test.lisp new file mode 100644 index 0000000..ee87a84 --- /dev/null +++ b/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))))