X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=strings.lisp;h=a6db99b655ddde6af58900eab8b8d289167a3bcf;hp=bf915077496962eb8c3eb680cdc8087f04a06664;hb=8d831065b8e830ea8b257aa7befd53bee7f49d5d;hpb=e9425347d51ee6933462b0c08c01979eee18c2eb diff --git a/strings.lisp b/strings.lisp index bf91507..a6db99b 100644 --- a/strings.lisp +++ b/strings.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: strings.lisp,v 1.3 2002/12/14 02:36:42 kevin Exp $ +;;;; $Id: strings.lisp,v 1.18 2003/05/05 19:54:14 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -18,7 +18,6 @@ (in-package :kmrcl) -(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) ;;; Strings @@ -45,33 +44,50 @@ (setq in-word nil)))) n-words)) -#+excl -(defun delimited-string-to-list (string &optional (separator #\space)) +#+allegro +(defun delimited-string-to-list (string &optional (separator #\space) skip-terminal) + "Uses allegro's internal function since that benchmarks faster than +my algorithm. Does allegro use assembly?" + (declare (string string) (character separator)) + (when skip-terminal + (let ((len (length string))) + (when (and (plusp len) (char= separator (char string (1- len)))) + (setq string (subseq string 0 (1- len)))))) (excl:delimited-string-to-list string separator)) -#-excl -(defun delimited-string-to-list (sequence &optional (separator #\space)) - "Split a string by a delimitor" - (loop - with start = 0 - for end = (position separator sequence :start start) - collect (subseq sequence start end) - until (null end) - do - (setf start (1+ end)))) - -#+excl -(defun list-to-delimited-string (list &optional (separator #\space)) - (excl:list-to-delimited-string list separator)) +(defun #-allegro delimited-string-to-list + #+allegro my-delimited-string-to-list + (string &optional (separator #\space) skip-terminal) + "split a string with delimiter" + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position separator string :start pos :end len) + (position separator string :start pos :end len)) + (previous nil)) + ((null end) + (cond + ((null previous) + (list string)) + (t + (incf previous) + (if (< previous len) + (push (subseq string previous) output) + (unless skip-terminal + (push "" output))) + (nreverse output)))) + (declare (type fixnum pos len) + (type (or null fixnum) end previous)) + (push (subseq string pos end) output) + (setq previous end) + (setq pos (1+ end)))) + -#-excl (defun list-to-delimited-string (list &optional (separator #\space)) - (let ((output (when list (format nil "~A" (car list))))) - (dolist (obj (rest list)) - (setq output (concatenate 'string output - (format nil "~A" separator) - (format nil "~A" obj)))) - output)) + (format nil (format nil "~~{~~A~~^~A~~}" separator) list)) (defun string-invert (str) "Invert case of a string" @@ -92,12 +108,7 @@ (defun substitute-string-for-char (procstr match-char subst-str) "Substitutes a string for a single matching character of a string" - (let ((pos (position match-char procstr))) - (if pos - (concatenate 'string - (subseq procstr 0 pos) subst-str - (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str)) - procstr))) + (substitute-chars-strings procstr (list (cons match-char subst-str)))) (defun string-substitute (string substring replacement-string) "String substitute by Larry Hunter. Obtained from Google" @@ -116,10 +127,19 @@ replacement-string)) (setq last-end (+ next-start substring-length))))) - (defun string-trim-last-character (s) -"Return the string less the last character" - (subseq s 0 (1- (length s)))) + "Return the string less the last character" + (let ((len (length s))) + (if (plusp len) + (subseq s 0 (1- len)) + s))) + +(defun nstring-trim-last-character (s) + "Return the string less the last character" + (let ((len (length s))) + (if (plusp len) + (nsubseq s 0 (1- len)) + s))) (defun string-hash (str &optional (bitmask 65535)) (let ((hash 0)) @@ -135,8 +155,9 @@ (defun whitespace? (c) (declare (character c)) - (declare (optimize (speed 3) (safety 0))) - (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed))) + (locally (declare (optimize (speed 3) (safety 0))) + (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) + (char= c #\Linefeed)))) (defun not-whitespace? (c) (not (whitespace? c))) @@ -146,3 +167,76 @@ (when (stringp str) (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)) + (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)) + +(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)) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + +(defun escape-xml-string (string) + "Escape invalid XML characters" + (substitute-chars-strings + string '((#\& . "&") (#\> . ">") (#\< . "<") (#\" . """)))) + + +(defun make-usb8-array (len) + (make-array len :adjustable nil + :fill-pointer nil + :element-type '(unsigned-byte 8))) + +(defun usb8-array-to-string (vec) + (let* ((len (length vec)) + (str (make-string len))) + (declare (fixnum len) + (simple-string str) + (optimize (speed 3))) + (dotimes (i len) + (declare (fixnum i)) + (setf (schar str i) (code-char (aref vec i)))) + str)) + +(defun string-to-usb8-array (str) + (let* ((len (length str)) + (vec (make-usb8-array len))) + (declare (fixnum len) + (type (array fixnum (*)) vec) + (optimize (speed 3))) + (dotimes (i len) + (declare (fixnum i)) + (setf (aref vec i) (char-code (schar str i)))) + vec)) +