Mercurial > core / lisp/lib/io/xsubseq.lisp
changeset 448: |
a37b1d3371fc |
parent: |
7c1383c08493
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sat, 15 Jun 2024 19:34:10 -0400 |
permissions: |
-rw-r--r-- |
description: |
fasl tweaks |
1 ;;; io/xsubseq.lisp --- Subseq Optimizations 3 ;; This is ported from Fukamachi's XSUBSEQ 9 (:import-from :sb-cltl2 :variable-information) 10 (:import-from :std/type :octet-vector) 14 :concatenated-xsubseqs 15 :null-concatenated-xsubseqs 16 :octet-concatenated-xsubseqs 17 :string-concatenated-xsubseqs 18 :make-concatenated-xsubseqs 25 (in-package :io/xsubseq) 27 (defstruct (xsubseq (:constructor make-xsubseq (data start &optional (end (length data)) 28 &aux (len (- end start))))) 30 (start 0 :type integer) 32 (len 0 :type integer)) 34 (defstruct (octet-xsubseq (:include xsubseq) 35 (:constructor make-octet-xsubseq (data start &optional (end (length data)) 36 &aux (len (- end start)))))) 38 (defstruct (string-xsubseq (:include xsubseq) 39 (:constructor make-string-xsubseq (data start &optional (end (length data)) 40 &aux (len (- end start)))))) 42 (defstruct (concatenated-xsubseqs (:constructor %make-concatenated-xsubseqs)) 45 (children nil :type list)) 47 (defun make-concatenated-xsubseqs (&rest children) 49 (make-null-concatenated-xsubseqs) 50 (%make-concatenated-xsubseqs :children children 57 (defstruct (null-concatenated-xsubseqs (:include concatenated-xsubseqs))) 59 (defstruct (octet-concatenated-xsubseqs (:include concatenated-xsubseqs))) 61 (defstruct (string-concatenated-xsubseqs (:include concatenated-xsubseqs))) 63 (defun xsubseq (data start &optional (end (length data))) 65 (octet-vector (make-octet-xsubseq data start end)) 66 (string (make-string-xsubseq data start end)) 67 (t (make-xsubseq data start end)))) 69 #+(or sbcl openmcl cmu allegro) 70 (define-compiler-macro xsubseq (&whole form &environment env data start &optional end) 72 ((constantp data) (type-of data)) 74 (assoc 'type (nth-value 2 (variable-information data env))))) 76 (eq (car data) 'make-string)) 82 (eq (car data) 'make-array) 83 (null (cadr (member :adjustable data))) 84 (null (cadr (member :fill-pointer data))) 85 (cadr (member :element-type data)))))) 86 (g-data (gensym "DATA"))) 90 ((subtypep type 'octet-vector) `(let ((,g-data ,data)) 91 (make-octet-xsubseq ,g-data ,start ,(or end `(length ,g-data))))) 92 ((subtypep type 'string) `(let ((,g-data ,data)) 93 (make-string-xsubseq ,g-data ,start ,(or end `(length ,g-data))))) 96 (defun %xnconc2 (seq1 seq2) 97 (flet ((seq-values (seq) 98 (if (concatenated-xsubseqs-p seq) 99 (values (concatenated-xsubseqs-children seq) 100 (concatenated-xsubseqs-last seq) 101 (concatenated-xsubseqs-len seq)) 102 (let ((children (list seq))) 103 (values children children 104 (xsubseq-len seq)))))) 105 (macrolet ((make-concatenated (type seq1 seq2) 106 `(multiple-value-bind (children last len) 109 ((eq type 'octet-vector) 'make-octet-concatenated-xsubseqs) 110 ((eq type 'string) 'make-string-concatenated-xsubseqs) 111 (t '%make-concatenated-xsubseqs)) 112 :len (+ (xsubseq-len ,seq1) len) 113 :children (cons ,seq1 children) 116 (null-concatenated-xsubseqs seq2) 117 (concatenated-xsubseqs 118 (multiple-value-bind (children last len) 120 (if (concatenated-xsubseqs-last seq1) 122 (rplacd (concatenated-xsubseqs-last seq1) 124 (setf (concatenated-xsubseqs-last seq1) last) 125 (incf (concatenated-xsubseqs-len seq1) len)) 126 ;; empty concatenated-xsubseqs 128 (setf (concatenated-xsubseqs-children seq1) children 129 (concatenated-xsubseqs-len seq1) len 130 (concatenated-xsubseqs-last seq1) last))) 133 (make-concatenated octet-vector seq1 seq2)) 135 (make-concatenated string seq1 seq2)) 136 (xsubseq (make-concatenated t seq1 seq2)))))) 138 (defun xnconc (subseq &rest more-subseqs) 139 (reduce #'%xnconc2 more-subseqs :initial-value subseq)) 141 (define-modify-macro xnconcf (subseq &rest more-subseqs) xnconc) 145 (xsubseq (xsubseq-len seq)) 146 (concatenated-xsubseqs (concatenated-xsubseqs-len seq)))) 148 (defun coerce-to-sequence (seq) 150 (octet-concatenated-xsubseqs (octet-concatenated-xsubseqs-to-sequence seq)) 151 (string-concatenated-xsubseqs (string-concatenated-xsubseqs-to-sequence seq)) 152 (concatenated-xsubseqs (concatenated-xsubseqs-to-sequence seq)) 153 (xsubseq (xsubseq-to-sequence seq)))) 155 #+(or sbcl openmcl cmu allegro) 156 (define-compiler-macro coerce-to-sequence (&whole form &environment env seq) 158 ((constantp seq) (type-of seq)) 160 (assoc 'type (nth-value 2 (variable-information seq env))))) 167 ((subtypep type 'octet-concatenated-xsubseqs) `(octet-concatenated-xsubseqs-to-sequence ,seq)) 168 ((subtypep type 'string-concatenated-xsubseqs) `(string-concatenated-xsubseqs-to-sequence ,seq)) 169 ((subtypep type 'concatenated-xsubseqs) `(concatenated-xsubseqs-to-sequence ,seq)) 170 ((subtypep type 'xsubseq) `(xsubseq-to-sequence ,seq)) 173 (defun coerce-to-string (seq) 175 (null-concatenated-xsubseqs "") 176 (octet-concatenated-xsubseqs (octet-concatenated-xsubseqs-to-string seq)) 177 (string-concatenated-xsubseqs (string-concatenated-xsubseqs-to-sequence seq)) 178 (octet-xsubseq (octet-xsubseq-to-string seq)) 179 (string-xsubseq (xsubseq-to-sequence seq)))) 181 #+(or sbcl openmcl cmu allegro) 182 (define-compiler-macro coerce-to-string (&whole form &environment env seq) 184 ((constantp seq) (type-of seq)) 186 (assoc 'type (nth-value 2 (variable-information seq env))))) 193 ((subtypep type 'octet-concatenated-xsubseqs) `(octet-concatenated-xsubseqs-to-string ,seq)) 194 ((subtypep type 'string-concatenated-xsubseqs) `(string-concatenated-xsubseqs-to-sequence ,seq)) 195 ((subtypep type 'octet-xsubseq) `(octet-xsubseq-to-string ,seq)) 196 ((subtypep type 'string-xsubseq) `(xsubseq-to-sequence ,seq)) 199 (defun xsubseq-to-sequence (seq) 200 (let ((result (make-array (xsubseq-len seq) 202 (array-element-type (xsubseq-data seq))))) 203 (replace result (xsubseq-data seq) 204 :start2 (xsubseq-start seq) 205 :end2 (xsubseq-end seq)) 208 (defun octet-xsubseq-to-string (seq) 209 (let ((result (make-array (xsubseq-len seq) 210 :element-type 'character))) 211 (declare (type simple-string result)) 212 (let ((data (xsubseq-data seq)) 213 (end (xsubseq-end seq))) 214 (do ((i (xsubseq-start seq) (1+ i)) 217 (setf (aref result j) 219 (the (unsigned-byte 8) 220 (aref (the octet-vector data) i)))))))) 222 (defun concatenated-xsubseqs-to-sequence (seq) 223 (let ((result (make-array (concatenated-xsubseqs-len seq) 225 (array-element-type (xsubseq-data (car (concatenated-xsubseqs-children seq))))))) 226 (loop with current-pos = 0 227 for seq in (concatenated-xsubseqs-children seq) 228 do (replace result (xsubseq-data seq) 230 :start2 (xsubseq-start seq) 231 :end2 (xsubseq-end seq)) 236 (defun octet-concatenated-xsubseqs-to-sequence (seq) 237 (let ((result (make-array (concatenated-xsubseqs-len seq) 238 :element-type '(unsigned-byte 8)))) 239 (declare (type octet-vector result)) 240 (loop with current-pos of-type integer = 0 241 for seq in (concatenated-xsubseqs-children seq) 242 do (replace result (the octet-vector (xsubseq-data seq)) 244 :start2 (xsubseq-start seq) 245 :end2 (xsubseq-end seq)) 250 (defun octet-concatenated-xsubseqs-to-string (seq) 251 (let ((result (make-array (concatenated-xsubseqs-len seq) 252 :element-type 'character))) 253 (declare (type simple-string result)) 254 (loop with current-pos = 0 255 for seq in (concatenated-xsubseqs-children seq) 256 do (do ((i (xsubseq-start seq) (1+ i)) 257 (j current-pos (1+ j))) 258 ((= i (xsubseq-end seq)) 259 (setf current-pos j)) 260 (setf (aref result j) 262 (the (unsigned-byte 8) 263 (aref (the octet-vector (xsubseq-data seq)) i)))))) 266 (defun string-concatenated-xsubseqs-to-sequence (seq) 267 (let ((result (make-string (concatenated-xsubseqs-len seq)))) 268 (declare (type simple-string result)) 269 (loop with current-pos of-type integer = 0 270 for seq in (concatenated-xsubseqs-children seq) 271 do (replace result (the simple-string (xsubseq-data seq)) 273 :start2 (xsubseq-start seq) 274 :end2 (xsubseq-end seq)) 279 (defmacro with-xsubseqs ((xsubseqs &key initial-value) &body body) 280 `(let ((,xsubseqs ,(or initial-value 281 `(make-null-concatenated-xsubseqs)))) 285 (null-concatenated-xsubseqs nil) 286 (xsubseq (xsubseq-to-sequence ,xsubseqs)) 287 (t (concatenated-xsubseqs-to-sequence ,xsubseqs)))))