r5114: Auto commit for Debian build

[kmrcl.git] / strings.lisp

diff --git a/strings.lisp b/strings.lisp
index b3a3d018a7cb557099df5137a89564329424472f..6c3eb448881c0d2c235cd5df3b0adffaeef33780 100644 (file)
--- a/strings.lisp
+++ b/strings.lisp
@@ -1,4 +1,4 @@
-<;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;


@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: strings.lisp,v 1.29 2003/05/16 08:32:10 kevin Exp $
+;;;; $Id: strings.lisp,v 1.39 2003/06/12 17:58:45 kevin Exp $

 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -17,7 +17,7 @@
 ;;;; *************************************************************************
 
 
 ;;;; *************************************************************************
 
 

-(in-package :kmrcl)
+(in-package #:kmrcl)

 
 ;;; Strings
 
 
 ;;; Strings
 


@@ -30,19 +30,19 @@
 
 (defun count-string-words (str)
   (declare (simple-string str)
 
 (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))
   (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)
 
 ;; 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))))
 
     (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"
 (defun delimited-string-to-list (string &optional (separator #\space) 
                                                  skip-terminal)
   "split a string with delimiter"


@@ -76,8 +84,8 @@
     (setq pos (1+ end))))
 
 
     (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"
 
 (defun string-invert (str)
   "Invert case of a string"


@@ -160,23 +168,25 @@
     (null (find-if #'not-whitespace? str))))
 
 (defun replaced-string-length (str repl-alist)
     (null (find-if #'not-whitespace? str))))
 
 (defun replaced-string-length (str repl-alist)

-  (declare (string str))
-  (let* ((orig-len (length str))
-        (new-len orig-len))
-    (declare (fixnum orig-len new-len))
-    (dotimes (i orig-len)
-      (declare (fixnum i))
+  (declare (simple-string str)
+          (fixnum orig-len new-len)
+          (optimize (speed 3) (safety 0) (space 0)))
+    (do* ((i 0 (1+ i))
+         (orig-len (length str))
+         (new-len orig-len))
+        ((= i orig-len) new-len)
+      (declare (fixnum i orig-len new-len))

       (let* ((c (char str i))
             (match (assoc c repl-alist :test #'char=)))
        (declare (character c))
        (when match
       (let* ((c (char str i))
             (match (assoc c repl-alist :test #'char=)))
        (declare (character c))
        (when match

-         (incf new-len (1- (length (cdr match)))))))
-    new-len))
+         (incf new-len (1- (length (cdr match))))))))

 
 (defun substitute-chars-strings (str repl-alist)
   "Replace all instances of a chars with a string. repl-alist is an assoc
 list of characters and replacement strings."
 
 (defun substitute-chars-strings (str repl-alist)
   "Replace all instances of a chars with a string. repl-alist is an assoc
 list of characters and replacement strings."

-  (declare (simple-string str))
+  (declare (simple-string str)
+          (optimize (speed 3) (safety 0) (space 0)))

   (do* ((orig-len (length str))
        (new-string (make-string (replaced-string-length str repl-alist)))
        (spos 0 (1+ spos))
   (do* ((orig-len (length str))
        (new-string (make-string (replaced-string-length str repl-alist)))
        (spos 0 (1+ spos))


@@ -190,7 +200,8 @@ list of characters and replacement strings."
       (if match
          (let* ((subst (cdr match))
                 (len (length subst)))
       (if match
          (let* ((subst (cdr match))
                 (len (length subst)))

-           (declare (fixnum len))
+           (declare (fixnum len)
+                    (simple-string subst))

            (dotimes (j len)
              (declare (fixnum j))
              (setf (char new-string dpos) (char subst j))
            (dotimes (j len)
              (declare (fixnum j))
              (setf (char new-string dpos) (char subst j))


@@ -201,39 +212,38 @@ list of characters and replacement strings."
 
 (defun escape-xml-string (string)
   "Escape invalid XML characters"
 
 (defun escape-xml-string (string)
   "Escape invalid XML characters"

-  (substitute-chars-strings 
-   string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;") (#\" . "&quot;"))))
-
+  (substitute-chars-strings string '((#\& . "&amp;") (#\< . "&lt;"))))

 
 (defun make-usb8-array (len)
 
 (defun make-usb8-array (len)

-  (make-array len :adjustable nil
-             :fill-pointer nil
-             :element-type '(unsigned-byte 8)))
+  (make-array len :element-type '(unsigned-byte 8)))

 
 (defun usb8-array-to-string (vec)
 
 (defun usb8-array-to-string (vec)

+  (declare (type (simple-array (unsigned-byte 8) (*)) vec))

   (let* ((len (length vec))
         (str (make-string len)))
     (declare (fixnum len)
             (simple-string str)
             (optimize (speed 3)))
   (let* ((len (length vec))
         (str (make-string len)))
     (declare (fixnum len)
             (simple-string str)
             (optimize (speed 3)))

-    (dotimes (i len)
+    (do ((i 0 (1+ i)))
+       ((= i len) str)

       (declare (fixnum i))
       (declare (fixnum i))

-      (setf (schar str i) (code-char (aref vec i))))
-    str))
+      (setf (schar str i) (code-char (aref vec i))))))

 
 (defun string-to-usb8-array (str)
 
 (defun string-to-usb8-array (str)

+  (declare (simple-string str))

   (let* ((len (length str))
         (vec (make-usb8-array len)))
     (declare (fixnum len)
   (let* ((len (length str))
         (vec (make-usb8-array len)))
     (declare (fixnum len)

-            (type (array fixnum (*)) vec)
+            (type (simple-array (unsigned-byte 8) (*)) vec)

             (optimize (speed 3)))
             (optimize (speed 3)))

-    (dotimes (i len)
+    (do ((i 0 (1+ i)))
+       ((= i len) vec)

       (declare (fixnum i))
       (declare (fixnum i))

-      (setf (aref vec i) (char-code (schar str i))))
-    vec))
+      (setf (aref vec i) (char-code (schar str i))))))

 
 (defun concat-separated-strings (separator &rest lists)
 
 (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)))
 
 (defun only-null-list-elements-p (lst)
   (or (null lst) (every #'null lst)))


@@ -280,8 +290,6 @@ Leading zeros are present."
 Leading zeros are present."
   (declare (optimize (speed 3) (safety 0) (space 0))
           (type fixnum len) (type integer num))
 Leading zeros are present."
   (declare (optimize (speed 3) (safety 0) (space 0))
           (type fixnum len) (type integer num))

-  (when pchar
-    (incf len))

   (do* ((zero-code (char-code #\0))
        (result (make-string len :initial-element #\0))
        (minus? (minusp num))
   (do* ((zero-code (char-code #\0))
        (result (make-string len :initial-element #\0))
        (minus? (minusp num))


@@ -289,9 +297,57 @@ Leading zeros are present."
        (pos (1- len) (1- pos))
        (mod (mod val 10) (mod val 10)))
       ((or (zerop val) (minusp pos))
        (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)) #\-))
+       (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)))))
        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)))
+
+(defun string-starts-with (start str)
+  (and (>= (length str) (length start))
+       (string-equal start str :end2 (length start))))
+
+(defun count-string-char (s c)
+  "Return a count of the number of times a character appears in a string"
+  (declare (simple-string s)
+          (character c)
+          (optimize (speed 3) (safety 0)))
+  (do ((len (length s))
+       (i 0 (1+ i))
+       (count 0))
+      ((= i len) count)
+    (declare (fixnum i len count))
+    (when (char= (schar s i) c)
+      (incf count))))