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