X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=strings.lisp;h=a6db99b655ddde6af58900eab8b8d289167a3bcf;hp=231ad6923fc1788d0ccfc5378a03e232a6cdf404;hb=8d831065b8e830ea8b257aa7befd53bee7f49d5d;hpb=3e172b14a7f4c73098ab3e1808db2b0bdc0bf986 diff --git a/strings.lisp b/strings.lisp index 231ad69..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.5 2002/12/28 07:59:37 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,54 +167,76 @@ (when (stringp str) (null (find-if #'not-whitespace? str)))) -#+ignore -(defun string-replace-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 replaced-string-length (str repl-alist) + (declare (string str)) (let* ((orig-len (length str)) - (new-len orign-len)) + (new-len orig-len)) (declare (fixnum orig-len new-len)) - (dotimes (i orign-len) + (dotimes (i orig-len) (declare (fixnum i)) - (let ((c (schar i str))) - ))) - str) + (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" - (string-replace-char-string - (string-replace-char-string string #\& "&") - #\< "<")) - -(defun string-replace-char-string (string repl-char repl-str) - "Replace all occurances of repl-char with repl-str" - (declare (simple-string string)) - (let ((count (count repl-char string))) - (declare (fixnum count)) - (if (zerop count) - string - (locally (declare (optimize (speed 3) (safety 0))) - (let* ((old-length (length string)) - (repl-length (length repl-str)) - (new-string (make-string (the fixnum - (+ old-length - (the fixnum - (* count - (the fixnum (1- repl-length))))))))) - (declare (fixnum old-length repl-length) - (simple-string new-string)) - (let ((newpos 0)) - (declare (fixnum newpos)) - (dotimes (oldpos (length string)) - (declare (fixnum oldpos)) - (if (char= repl-char (schar string oldpos)) - (dotimes (repl-pos repl-length) - (declare (fixnum repl-pos)) - (setf (schar new-string newpos) (schar repl-str repl-pos)) - (incf newpos)) - (progn - (setf (schar new-string newpos) (schar string oldpos)) - (incf newpos))))) - new-string))))) - - + (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)) +