strings.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          strings.lisp
   6 ;;;; Purpose:       Strings utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19
  20 (in-package #:kmrcl)
  21
  22 ;;; Strings
  23
  24 (defmacro string-append (outputstr &rest args)
  25   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
  26
  27 (defun list-to-string (lst)
  28   "Converts a list to a string, doesn't include any delimiters between elements"
  29   (format nil "~{~A~}" lst))
  30
  31 (defun count-string-words (str)
  32   (declare (simple-string str)
  33            (optimize (speed 3) (safety 0) (space 0)))
  34   (let ((n-words 0)
  35         (in-word nil))
  36     (declare (fixnum n-words))
  37     (do* ((len (length str))
  38           (i 0 (1+ i)))
  39         ((= i len) n-words)
  40       (declare (fixnum i))
  41       (if (alphanumericp (schar str i))
  42           (unless in-word
  43             (incf n-words)
  44             (setq in-word t))
  45         (setq in-word nil)))))
  46
  47 ;; From Larry Hunter with modifications
  48 (defun position-char (char string start max)
  49   (declare (optimize (speed 3) (safety 0) (space 0))
  50            (fixnum start max) (simple-string string))
  51   (do* ((i start (1+ i)))
  52        ((= i max) nil)
  53     (declare (fixnum i))
  54     (when (char= char (schar string i)) (return i))))
  55
  56 (defun position-not-char (char string start max)
  57   (declare (optimize (speed 3) (safety 0) (space 0))
  58            (fixnum start max) (simple-string string))
  59   (do* ((i start (1+ i)))
  60        ((= i max) nil)
  61     (declare (fixnum i))
  62     (when (char/= char (schar string i)) (return i))))
  63
  64 (defun delimited-string-to-list (string &optional (separator #\space)
  65                                                   skip-terminal)
  66   "split a string with delimiter"
  67   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
  68            (type string string)
  69            (type character separator))
  70   (do* ((len (length string))
  71         (output '())
  72         (pos 0)
  73         (end (position-char separator string pos len)
  74              (position-char separator string pos len)))
  75        ((null end)
  76         (if (< pos len)
  77             (push (subseq string pos) output)
  78             (when (or (not skip-terminal) (zerop len))
  79               (push "" output)))
  80         (nreverse output))
  81     (declare (type fixnum pos len)
  82              (type (or null fixnum) end))
  83     (push (subseq string pos end) output)
  84     (setq pos (1+ end))))
  85
  86
  87 (defun list-to-delimited-string (list &optional (separator " "))
  88   (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list))
  89
  90 (defun string-invert (str)
  91   "Invert case of a string"
  92   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  93            (simple-string str))
  94   (let ((up nil) (down nil))
  95     (block skip
  96       (loop for char of-type character across str do
  97             (cond ((upper-case-p char)
  98                    (if down (return-from skip str) (setf up t)))
  99                   ((lower-case-p char)
 100                    (if up   (return-from skip str) (setf down t)))))
 101       (if up (string-downcase str) (string-upcase str)))))
 102
 103 (defun add-sql-quotes (s)
 104   (substitute-string-for-char s #\' "''"))
 105
 106 (defun escape-backslashes (s)
 107   (substitute-string-for-char s #\\ "\\\\"))
 108
 109 (defun substitute-string-for-char (procstr match-char subst-str)
 110   "Substitutes a string for a single matching character of a string"
 111   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 112
 113 (defun string-substitute (string substring replacement-string)
 114   "String substitute by Larry Hunter. Obtained from Google"
 115   (let ((substring-length (length substring))
 116         (last-end 0)
 117         (new-string ""))
 118     (do ((next-start
 119           (search substring string)
 120           (search substring string :start2 last-end)))
 121         ((null next-start)
 122          (concatenate 'string new-string (subseq string last-end)))
 123       (setq new-string
 124         (concatenate 'string
 125           new-string
 126           (subseq string last-end next-start)
 127           replacement-string))
 128       (setq last-end (+ next-start substring-length)))))
 129
 130 (defun string-trim-last-character (s)
 131   "Return the string less the last character"
 132   (let ((len (length s)))
 133     (if (plusp len)
 134         (subseq s 0 (1- len))
 135         s)))
 136
 137 (defun nstring-trim-last-character (s)
 138   "Return the string less the last character"
 139   (let ((len (length s)))
 140     (if (plusp len)
 141         (nsubseq s 0 (1- len))
 142         s)))
 143
 144 (defun string-hash (str &optional (bitmask 65535))
 145   (let ((hash 0))
 146     (declare (fixnum hash)
 147              (simple-string str))
 148     (dotimes (i (length str))
 149       (declare (fixnum i))
 150       (setq hash (+ hash (char-code (char str i)))))
 151     (logand hash bitmask)))
 152
 153 (defun is-string-empty (str)
 154   (zerop (length str)))
 155
 156 (defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed
 157                              #+allegro #\%space
 158                              #+lispworks #\No-Break-Space))
 159
 160 (defun is-char-whitespace (c)
 161   (declare (character c) (optimize (speed 3) (safety 0)))
 162   (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
 163       (char= c #\Linefeed)
 164       #+allegro (char= c #\%space)
 165       #+lispworks (char= c #\No-Break-Space)))
 166
 167 (defun is-string-whitespace (str)
 168   "Return t if string is all whitespace"
 169   (every #'is-char-whitespace str))
 170
 171 (defun string-right-trim-whitespace (str)
 172   (string-right-trim *whitespace-chars* str))
 173
 174 (defun string-left-trim-whitespace (str)
 175   (string-left-trim *whitespace-chars* str))
 176
 177 (defun string-trim-whitespace (str)
 178   (string-trim *whitespace-chars* str))
 179
 180 (defun replaced-string-length (str repl-alist)
 181   (declare (simple-string str)
 182            (optimize (speed 3) (safety 0) (space 0)))
 183     (do* ((i 0 (1+ i))
 184           (orig-len (length str))
 185           (new-len orig-len))
 186          ((= i orig-len) new-len)
 187       (declare (fixnum i orig-len new-len))
 188       (let* ((c (char str i))
 189              (match (assoc c repl-alist :test #'char=)))
 190         (declare (character c))
 191         (when match
 192           (incf new-len (1- (length
 193                              (the simple-string (cdr match)))))))))
 194
 195 (defun substitute-chars-strings (str repl-alist)
 196   "Replace all instances of a chars with a string. repl-alist is an assoc
 197 list of characters and replacement strings."
 198   (declare (simple-string str)
 199            (optimize (speed 3) (safety 0) (space 0)))
 200   (do* ((orig-len (length str))
 201         (new-string (make-string (replaced-string-length str repl-alist)))
 202         (spos 0 (1+ spos))
 203         (dpos 0))
 204       ((>= spos orig-len)
 205        new-string)
 206     (declare (fixnum spos dpos) (simple-string new-string))
 207     (let* ((c (char str spos))
 208            (match (assoc c repl-alist :test #'char=)))
 209       (declare (character c))
 210       (if match
 211           (let* ((subst (cdr match))
 212                  (len (length subst)))
 213             (declare (fixnum len)
 214                      (simple-string subst))
 215             (dotimes (j len)
 216               (declare (fixnum j))
 217               (setf (char new-string dpos) (char subst j))
 218               (incf dpos)))
 219         (progn
 220           (setf (char new-string dpos) c)
 221           (incf dpos))))))
 222
 223 (defun escape-xml-string (string)
 224   "Escape invalid XML characters"
 225   (substitute-chars-strings string '((#\& . "&amp;") (#\< . "&lt;"))))
 226
 227 (defun make-usb8-array (len)
 228   (make-array len :element-type '(unsigned-byte 8)))
 229
 230 (defun usb8-array-to-string (vec &key (start 0) end)
 231   (declare (type (simple-array (unsigned-byte 8) (*)) vec)
 232            (fixnum start))
 233   (unless end
 234     (setq end (length vec)))
 235   (let* ((len (- end start))
 236          (str (make-string len)))
 237     (declare (fixnum len)
 238              (simple-string str)
 239              (optimize (speed 3) (safety 0)))
 240     (do ((i 0 (1+ i)))
 241         ((= i len) str)
 242       (declare (fixnum i))
 243       (setf (schar str i) (code-char (aref vec (the fixnum (+ i start))))))))
 244
 245 (defun string-to-usb8-array (str)
 246   (declare (simple-string str))
 247   (let* ((len (length str))
 248          (vec (make-usb8-array len)))
 249     (declare (fixnum len)
 250              (type (simple-array (unsigned-byte 8) (*)) vec)
 251              (optimize (speed 3)))
 252     (do ((i 0 (1+ i)))
 253         ((= i len) vec)
 254       (declare (fixnum i))
 255       (setf (aref vec i) (char-code (schar str i))))))
 256
 257 (defun concat-separated-strings (separator &rest lists)
 258   (format nil (concatenate 'string "~{~A~^" (string separator) "~}")
 259           (append-sublists lists)))
 260
 261 (defun only-null-list-elements-p (lst)
 262   (or (null lst) (every #'null lst)))
 263
 264 (defun print-separated-strings (strm separator &rest lists)
 265   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
 266                      (compilation-speed 0)))
 267   (do* ((rest-lists lists (cdr rest-lists))
 268         (list (car rest-lists) (car rest-lists))
 269         (last-list (only-null-list-elements-p (cdr rest-lists))
 270                    (only-null-list-elements-p (cdr rest-lists))))
 271        ((null rest-lists) strm)
 272     (do* ((lst list (cdr lst))
 273           (elem (car lst) (car lst))
 274           (last-elem (null (cdr lst)) (null (cdr lst))))
 275          ((null lst))
 276       (write-string elem strm)
 277       (unless (and last-elem last-list)
 278         (write-string separator strm)))))
 279
 280 (defun prefixed-fixnum-string (num pchar len)
 281   "Outputs a string of LEN digit with an optional initial character PCHAR.
 282 Leading zeros are present."
 283   (declare (optimize (speed 3) (safety 0) (space 0))
 284            (type fixnum num len))
 285   (when pchar
 286     (incf len))
 287   (do* ((zero-code (char-code #\0))
 288         (result (make-string len :initial-element #\0))
 289         (minus? (minusp num))
 290         (val (if minus? (- num) num)
 291              (nth-value 0 (floor val 10)))
 292         (pos (1- len) (1- pos))
 293         (mod (mod val 10) (mod val 10)))
 294       ((or (zerop val) (minusp pos))
 295        (when pchar
 296          (setf (schar result 0) pchar))
 297        (when minus? (setf (schar result (if pchar 1 0)) #\-))
 298        result)
 299     (declare (fixnum val mod zero-code pos) (simple-string result))
 300     (setf (schar result pos) (code-char (+ zero-code mod)))))
 301
 302 (defun integer-string (num len)
 303   "Outputs a string of LEN digit with an optional initial character PCHAR.
 304 Leading zeros are present."
 305   (declare (optimize (speed 3) (safety 0) (space 0))
 306            (type fixnum len)
 307            (type integer num))
 308   (do* ((zero-code (char-code #\0))
 309         (result (make-string len :initial-element #\0))
 310         (minus? (minusp num))
 311         (val (if minus? (- 0 num) num)
 312              (nth-value 0 (floor val 10)))
 313         (pos (1- len) (1- pos))
 314         (mod (mod val 10) (mod val 10)))
 315       ((or (zerop val) (minusp pos))
 316        (when minus? (setf (schar result 0) #\-))
 317        result)
 318     (declare (fixnum mod zero-code pos) (simple-string result) (integer val))
 319     (setf (schar result pos) (code-char (+ zero-code mod)))))
 320
 321 (defun fast-string-search (substr str substr-length startpos endpos)
 322   "Optimized search for a substring in a simple-string"
 323   (declare (simple-string substr str)
 324            (fixnum substr-length startpos endpos)
 325            (optimize (speed 3) (space 0) (safety 0)))
 326   (do* ((pos startpos (1+ pos))
 327         (lastpos (- endpos substr-length)))
 328        ((> pos lastpos) nil)
 329     (declare (fixnum pos lastpos))
 330     (do ((i 0 (1+ i)))
 331         ((= i substr-length)
 332          (return-from fast-string-search pos))
 333       (declare (fixnum i))
 334       (unless (char= (schar str (+ i pos)) (schar substr i))
 335         (return nil)))))
 336
 337 (defun string-delimited-string-to-list (str substr)
 338   "splits a string delimited by substr into a list of strings"
 339   (declare (simple-string str substr)
 340            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
 341                      (debug 0)))
 342   (do* ((substr-len (length substr))
 343         (strlen (length str))
 344         (output '())
 345         (pos 0)
 346         (end (fast-string-search substr str substr-len pos strlen)
 347              (fast-string-search substr str substr-len pos strlen)))
 348        ((null end)
 349         (when (< pos strlen)
 350           (push (subseq str pos) output))
 351         (nreverse output))
 352     (declare (fixnum strlen substr-len pos)
 353              (type (or fixnum null) end))
 354     (push (subseq str pos end) output)
 355     (setq pos (+ end substr-len))))
 356
 357 (defun string-to-list-skip-delimiter (str &optional (delim #\space))
 358   "Return a list of strings, delimited by spaces, skipping spaces."
 359   (declare (simple-string str)
 360            (optimize (speed 0) (space 0) (safety 0)))
 361   (do* ((results '())
 362         (end (length str))
 363         (i (position-not-char delim str 0 end)
 364            (position-not-char delim str j end))
 365         (j (when i (position-char delim str i end))
 366            (when i (position-char delim str i end))))
 367        ((or (null i) (null j))
 368         (when (and i (< i end))
 369           (push (subseq str i end) results))
 370         (nreverse results))
 371     (declare (fixnum end)
 372              (type (or fixnum null) i j))
 373     (push (subseq str i j) results)))
 374
 375 (defun string-starts-with (start str)
 376   (and (>= (length str) (length start))
 377        (string-equal start str :end2 (length start))))
 378
 379 (defun count-string-char (s c)
 380   "Return a count of the number of times a character appears in a string"
 381   (declare (simple-string s)
 382            (character c)
 383            (optimize (speed 3) (safety 0)))
 384   (do ((len (length s))
 385        (i 0 (1+ i))
 386        (count 0))
 387       ((= i len) count)
 388     (declare (fixnum i len count))
 389     (when (char= (schar s i) c)
 390       (incf count))))
 391
 392 (defun count-string-char-if (pred s)
 393   "Return a count of the number of times a predicate is true
 394 for characters in a string"
 395   (declare (simple-string s)
 396            (type (or function symbol) pred)
 397            (optimize (speed 3) (safety 0) (space 0)))
 398   (do ((len (length s))
 399        (i 0 (1+ i))
 400        (count 0))
 401       ((= i len) count)
 402     (declare (fixnum i len count))
 403     (when (funcall pred (schar s i))
 404       (incf count))))
 405
 406
 407 ;;; URL Encoding
 408
 409 (defun non-alphanumericp (ch)
 410   (not (alphanumericp ch)))
 411
 412 (defvar +hex-chars+ "0123456789ABCDEF")
 413 (declaim (type simple-string +hex-chars+))
 414
 415 (defun hexchar (n)
 416   (declare (type (integer 0 15) n))
 417   (schar +hex-chars+ n))
 418
 419 (defconstant* +char-code-lower-a+ (char-code #\a))
 420 (defconstant* +char-code-upper-a+ (char-code #\A))
 421 (defconstant* +char-code-0+ (char-code #\0))
 422 (declaim (type fixnum +char-code-0+ +char-code-upper-a+
 423                +char-code-0))
 424
 425 (defun charhex (ch)
 426   "convert hex character to decimal"
 427   (let ((code (char-code (char-upcase ch))))
 428     (declare (fixnum ch))
 429     (if (>= code +char-code-upper-a+)
 430         (+ 10 (- code +char-code-upper-a+))
 431         (- code +char-code-0+))))
 432
 433 (defun encode-uri-string (query)
 434   "Escape non-alphanumeric characters for URI fields"
 435   (declare (simple-string query)
 436            (optimize (speed 3) (safety 0) (space 0)))
 437   (do* ((count (count-string-char-if #'non-alphanumericp query))
 438         (len (length query))
 439         (new-len (+ len (* 2 count)))
 440         (str (make-string new-len))
 441         (spos 0 (1+ spos))
 442         (dpos 0 (1+ dpos)))
 443       ((= spos len) str)
 444     (declare (fixnum count len new-len spos dpos)
 445              (simple-string str))
 446     (let ((ch (schar query spos)))
 447       (if (non-alphanumericp ch)
 448           (let ((c (char-code ch)))
 449             (setf (schar str dpos) #\%)
 450             (incf dpos)
 451             (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
 452             (incf dpos)
 453             (setf (schar str dpos) (hexchar (logand c 15))))
 454         (setf (schar str dpos) ch)))))
 455
 456 (defun decode-uri-string (query)
 457   "Unescape non-alphanumeric characters for URI fields"
 458   (declare (simple-string query)
 459            (optimize (speed 3) (safety 0) (space 0)))
 460   (do* ((count (count-string-char query #\%))
 461         (len (length query))
 462         (new-len (- len (* 2 count)))
 463         (str (make-string new-len))
 464         (spos 0 (1+ spos))
 465         (dpos 0 (1+ dpos)))
 466       ((= spos len) str)
 467     (declare (fixnum count len new-len spos dpos)
 468              (simple-string str))
 469     (let ((ch (schar query spos)))
 470       (if (char= #\% ch)
 471           (let ((c1 (charhex (schar query (1+ spos))))
 472                 (c2 (charhex (schar query (+ spos 2)))))
 473             (declare (fixnum c1 c2))
 474             (setf (schar str dpos)
 475                   (code-char (logior c2 (ash c1 4))))
 476             (incf spos 2))
 477         (setf (schar str dpos) ch)))))
 478
 479
 480
 481 (eval-when (:compile-toplevel :load-toplevel :execute)
 482   (defvar +unambiguous-charset+
 483     "abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
 484   (defconstant* +unambiguous-length+ (length +unambiguous-charset+)))
 485
 486 (defun random-char (&optional (set :lower-alpha))
 487   (ecase set
 488     (:lower-alpha
 489      (code-char (+ +char-code-lower-a+ (random 26))))
 490     (:lower-alphanumeric
 491      (let ((n (random 36)))
 492        (if (>= n 26)
 493            (code-char (+ +char-code-0+ (- n 26)))
 494          (code-char (+ +char-code-lower-a+ n)))))
 495     (:upper-alpha
 496      (code-char (+ +char-code-upper-a+ (random 26))))
 497     (:unambiguous
 498      (schar +unambiguous-charset+ (random +unambiguous-length+)))
 499     (:upper-lower-alpha
 500      (let ((n (random 52)))
 501        (if (>= n 26)
 502            (code-char (+ +char-code-upper-a+ (- n 26)))
 503          (code-char (+ +char-code-lower-a+ n)))))))
 504
 505
 506 (defun random-string (&key (length 10) (set :lower-alpha))
 507   "Returns a random lower-case string."
 508   (declare (optimize (speed 3)))
 509   (let ((s (make-string length)))
 510     (declare (simple-string s))
 511     (dotimes (i length s)
 512       (setf (schar s i) (random-char set)))))
 513
 514
 515 (defun first-char (s)
 516   (declare (simple-string s))
 517   (when (and (stringp s) (plusp (length s)))
 518     (schar s 0)))
 519
 520 (defun last-char (s)
 521   (declare (simple-string s))
 522   (when (stringp s)
 523     (let ((len (length s)))
 524       (when (plusp len))
 525       (schar s (1- len)))))
 526
 527 (defun ensure-string (v)
 528   (typecase v
 529     (string v)
 530     (character (string v))
 531     (symbol (symbol-name v))
 532     (otherwise (write-to-string v))))
 533
 534 (defun string-right-trim-one-char (char str)
 535   (declare (simple-string str))
 536   (let* ((len (length str))
 537          (last (1- len)))
 538     (declare (fixnum len last))
 539     (if (char= char (schar str last))
 540         (subseq str 0 last)
 541       str)))
 542
 543
 544 (defun string-strip-ending (str endings)
 545   (if (stringp endings)
 546       (setq endings (list endings)))
 547   (let ((len (length str)))
 548     (dolist (ending endings str)
 549       (when (and (>= len (length ending))
 550                  (string-equal ending
 551                                (subseq str (- len
 552                                               (length ending)))))
 553         (return-from string-strip-ending
 554           (subseq str 0 (- len (length ending))))))))
 555
 556
 557 (defun string-maybe-shorten (str maxlen)
 558   (string-elide str maxlen :end))
 559
 560 (defun string-elide (str maxlen position)
 561   (declare (fixnum maxlen))
 562   (let ((len (length str)))
 563     (declare (fixnum len))
 564     (cond
 565      ((<= len maxlen)
 566       str)
 567      ((<= maxlen 3)
 568       "...")
 569      ((eq position :middle)
 570       (multiple-value-bind (mid remain) (truncate maxlen 2)
 571         (let ((end1 (- mid 1))
 572               (start2 (- len (- mid 2) remain)))
 573           (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
 574      ((or (eq position :end) t)
 575       (concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
 576
 577 (defun shrink-vector (str size)
 578   #+allegro
 579   (excl::.primcall 'sys::shrink-svector str size)
 580   #+cmu
 581   (lisp::shrink-vector str size)
 582   #+lispworks
 583   (system::shrink-vector$vector str size)
 584   #+sbcl
 585   (sb-kernel:shrink-vector str size)
 586   #+scl
 587   (common-lisp::shrink-vector str size)
 588   #-(or allegro cmu lispworks sbcl scl)
 589   (setq str (subseq str 0 size))
 590   str)
 591
 592 (defun lex-string (string &key (whitespace '(#\space #\newline)))
 593   "Separates a string at whitespace and returns a list of strings"
 594   (flet ((is-sep (char) (member char whitespace :test #'char=)))
 595     (let ((tokens nil))
 596       (do* ((token-start
 597              (position-if-not #'is-sep string)
 598              (when token-end
 599                (position-if-not #'is-sep string :start (1+ token-end))))
 600             (token-end
 601              (when token-start
 602                (position-if #'is-sep string :start token-start))
 603              (when token-start
 604                (position-if #'is-sep string :start token-start))))
 605            ((null token-start) (nreverse tokens))
 606         (push (subseq string token-start token-end) tokens)))))
 607
 608 (defun split-alphanumeric-string (string)
 609   "Separates a string at any non-alphanumeric chararacter"
 610   (declare (simple-string string)
 611            (optimize (speed 3) (safety 0)))
 612   (flet ((is-sep (char)
 613            (declare (character char))
 614            (and (non-alphanumericp char)
 615                 (not (char= #\_ char)))))
 616     (let ((tokens nil))
 617       (do* ((token-start
 618              (position-if-not #'is-sep string)
 619              (when token-end
 620                (position-if-not #'is-sep string :start (1+ token-end))))
 621             (token-end
 622              (when token-start
 623                (position-if #'is-sep string :start token-start))
 624              (when token-start
 625                (position-if #'is-sep string :start token-start))))
 626            ((null token-start) (nreverse tokens))
 627         (push (subseq string token-start token-end) tokens)))))
 628
 629
 630 (defun trim-non-alphanumeric (word)
 631   "Strip non-alphanumeric characters from beginning and end of a word."
 632   (declare (simple-string word)
 633            (optimize (speed 3) (safety 0) (space 0)))
 634   (let* ((start 0)
 635          (len (length word))
 636          (end len))
 637     (declare (fixnum start end len))
 638     (do ((done nil))
 639         ((or done (= start end)))
 640       (if (alphanumericp (schar word start))
 641           (setq done t)
 642         (incf start)))
 643     (when (> end start)
 644       (do ((done nil))
 645           ((or done (= start end)))
 646         (if (alphanumericp (schar word (1- end)))
 647             (setq done t)
 648           (decf end))))
 649     (if (or (plusp start) (/= len end))
 650         (subseq word start end)
 651       word)))
 652
 653
 654 (defun collapse-whitespace (s)
 655   "Convert multiple whitespace characters to a single space character."
 656   (declare (simple-string s)
 657            (optimize (speed 3) (safety 0)))
 658   (with-output-to-string (stream)
 659     (do ((pos 0 (1+ pos))
 660          (in-white nil)
 661          (len (length s)))
 662         ((= pos len))
 663       (declare (fixnum pos len))
 664       (let ((c (schar s pos)))
 665         (declare (character c))
 666         (cond
 667          ((kl:is-char-whitespace c)
 668           (unless in-white
 669             (write-char #\space stream))
 670           (setq in-white t))
 671          (t
 672           (setq in-white nil)
 673           (write-char c stream)))))))
 674
 675 (defun string->list (string)
 676   (let ((eof (list nil)))
 677     (with-input-from-string (stream string)
 678       (do ((x (read stream nil eof) (read stream nil eof))
 679            (l nil (cons x l)))
 680           ((eq x eof) (nreverse l))))))