X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=strings.lisp;h=a070731a2afff44463a1def6f1bae6619e2c4fc2;hb=5dbd1fda3cf8f68c070cf3036dc6b1b536bc9f5a;hp=937f67039e45bbc9225ad25df9866ead8c479c22;hpb=066d1f100407cebbf9b28ee9135d8538876e8c3f;p=kmrcl.git diff --git a/strings.lisp b/strings.lisp index 937f670..a070731 100644 --- a/strings.lisp +++ b/strings.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: strings.lisp,v 1.27 2003/05/14 21:31:42 kevin Exp $ +;;;; $Id: strings.lisp,v 1.36 2003/06/07 05:45:14 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -17,7 +17,7 @@ ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) ;;; Strings @@ -30,19 +30,19 @@ (defun count-string-words (str) (declare (simple-string str) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0) (space 0))) (let ((n-words 0) (in-word nil)) (declare (fixnum n-words)) - (dotimes (i (length str)) - (let ((ch (char str i))) - (declare (character ch)) - (if (alphanumericp ch) - (unless in-word - (incf n-words) - (setq in-word t)) - (setq in-word nil)))) - n-words)) + (do* ((len (length str)) + (i 0 (1+ i))) + ((= i len) n-words) + (declare (fixnum i)) + (if (alphanumericp (schar str i)) + (unless in-word + (incf n-words) + (setq in-word t)) + (setq in-word nil))))) ;; From Larry Hunter with modifications (defun position-char (char string start max) @@ -53,6 +53,14 @@ (declare (fixnum i)) (when (char= char (schar string i)) (return i)))) +(defun position-not-char (char string start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char/= char (schar string i)) (return i)))) + (defun delimited-string-to-list (string &optional (separator #\space) skip-terminal) "split a string with delimiter" @@ -76,8 +84,8 @@ (setq pos (1+ end)))) -(defun list-to-delimited-string (list &optional (separator #\space)) - (format nil (format nil "~~{~~A~~^~A~~}" separator) list)) +(defun list-to-delimited-string (list &optional (separator " ")) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list)) (defun string-invert (str) "Invert case of a string" @@ -201,9 +209,7 @@ list of characters and replacement strings." (defun escape-xml-string (string) "Escape invalid XML characters" - (substitute-chars-strings - string '((#\& . "&") (#\> . ">") (#\< . "<") (#\" . """)))) - + (substitute-chars-strings string '((#\& . "&") (#\< . "<")))) (defun make-usb8-array (len) (make-array len :adjustable nil @@ -233,7 +239,8 @@ list of characters and replacement strings." vec)) (defun concat-separated-strings (separator &rest lists) - (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists))) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") + (append-sublists lists))) (defun only-null-list-elements-p (lst) (or (null lst) (every #'null lst))) @@ -255,22 +262,72 @@ list of characters and replacement strings." (write-string separator strm))))) (defun prefixed-fixnum-string (num pchar len) - "Outputs a string of LEN chars with the initial character being -PCHAR. Leading zeros are printed." + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present." + (declare (optimize (speed 3) (safety 0) (space 0)) + (type fixnum num len)) + (when pchar + (incf len)) + (do* ((zero-code (char-code #\0)) + (result (make-string len :initial-element #\0)) + (minus? (minusp num)) + (val (if minus? (- 0 num) num) (floor (/ val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when pchar + (setf (schar result 0) pchar)) + (when minus? (setf (schar result (if pchar 1 0)) #\-)) + result) + (declare (fixnum val mod zero-code pos) (simple-string result)) + (setf (schar result pos) (code-char (+ zero-code mod))))) + +(defun integer-string (num len) + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present." (declare (optimize (speed 3) (safety 0) (space 0)) - (type fixnum v len)) - (let ((zero-code (char-code #\0)) + (type fixnum len) (type integer num)) + (do* ((zero-code (char-code #\0)) (result (make-string len :initial-element #\0)) - (pos (1- len))) - (declare (fixnum zero-code pos) - (simple-string result)) - (do* ((val num (floor (/ val 10))) - (mod (nth-value 1 (floor val 10)) - (nth-value 1 (floor val 10)))) - ((or (zerop val) (minusp pos))) - (declare (fixnum val mod)) - (setf (schar result pos) (code-char (+ zero-code mod))) - (decf pos)) - (when pchar - (setf (schar result 0) pchar)) - result)) + (minus? (minusp num)) + (val (if minus? (- 0 num) num) (floor (/ val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when minus? (setf (schar result 0) #\-)) + result) + (declare (fixnum mod zero-code pos) (simple-string result) (integer val)) + (setf (schar result pos) (code-char (+ zero-code mod))))) + +(defun fast-string-search (substr str substr-length startpos endpos) + "Optimized search for a substring in a simple-string" + (declare (simple-string substr str) + (fixnum substr-length startpos endpos) + (optimize (speed 3) (space 0) (safety 0))) + (do* ((pos startpos (1+ pos)) + (lastpos (- endpos substr-length))) + ((> pos lastpos) nil) + (declare (fixnum pos lastpos)) + (do ((i 0 (1+ i))) + ((= i substr-length) + (return-from fast-string-search pos)) + (declare (fixnum i)) + (unless (char= (schar str (+ i pos)) (schar substr i)) + (return nil))))) + +(defun string-to-list-skip-delimiter (str &optional (delim #\space)) + "Return a list of strings, delimited by spaces, skipping spaces." + (declare (simple-string str) + (optimize (speed 0) (space 0) (safety 0))) + (do* ((results '()) + (end (length str)) + (i (position-not-char delim str 0 end) + (position-not-char delim str j end)) + (j (when i (position-char delim str i end)) + (when i (position-char delim str i end)))) + ((or (null i) (null j)) + (when (and i (< i end)) + (push (subseq str i end) results)) + (nreverse results)) + (declare (fixnum i j end)) + (push (subseq str i j) results)))