;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/flexi-streams/strings.lisp,v 1.22 2008/05/21 01:43:43 edi Exp $ ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :flexi-streams) (defun string-to-octets (string &key (external-format :latin1) (start 0) (end (length string))) "Converts the Lisp string STRING from START to END to an array of octets corresponding to the external format designated by EXTERNAL-FORMAT." (declare #.*standard-optimize-settings*) (declare (fixnum start end) (string string)) (setq external-format (maybe-convert-external-format external-format)) (let ((factor (encoding-factor external-format)) (length (- end start))) (declare (fixnum length)) (etypecase factor (integer (let ((octets (make-array (* factor length) :element-type 'octet)) (j 0)) (declare (fixnum j)) (flet ((writer (octet) (declare (octet octet)) (setf (aref (the (array octet *) octets) j) octet) (incf j))) (declare (dynamic-extent (function writer))) (loop for i of-type fixnum from start below end do (char-to-octets external-format (char string i) #'writer))) octets)) (double-float ;; this is a bit clunky but hopefully a bit more efficient than ;; using VECTOR-PUSH-EXTEND (let* ((octets-length (ceiling (* factor length))) (octets (make-array octets-length :element-type 'octet :fill-pointer t :adjustable t)) (i start) (j 0)) (declare (fixnum i j octets-length) (double-float factor)) (flet ((writer (octet) (declare (octet octet)) (when (>= j octets-length) (setq factor (* factor 2.0d0)) (incf octets-length (the fixnum (ceiling (* factor (- end i))))) (adjust-array octets octets-length :fill-pointer t)) (setf (aref (the (array octet *) octets) j) octet) (incf j))) (declare (dynamic-extent (function writer))) (loop (when (>= i end) (return)) (char-to-octets external-format (char string i) #'writer) (incf i)) (setf (fill-pointer octets) j) octets)))))) (defun octets-to-string (sequence &key (external-format :latin1) (start 0) (end (length sequence))) "Converts the Lisp sequence SEQUENCE of octets from START to END to string using the external format designated by EXTERNAL-FORMAT." (declare #.*standard-optimize-settings*) (declare (fixnum start end)) (setq external-format (maybe-convert-external-format external-format)) (let* ((factor (encoding-factor external-format)) (length (- end start)) (i start) (reader (etypecase sequence ((array octet *) (lambda () (and (< i end) (prog1 (aref (the (array octet *) sequence) i) (incf i))))) ((array * *) (lambda () (and (< i end) (prog1 (aref sequence i) (incf i))))) (list (lambda () (and (< i end) (prog1 (nth i sequence) (incf i)))))))) (declare (fixnum i length) (dynamic-extent reader)) (labels ((pseudo-writer (octet) (declare (ignore octet)) (decf i)) (unreader (char) (char-to-octets external-format char #'pseudo-writer))) (declare (dynamic-extent (function pseudo-writer) (function unreader))) (let ((*current-unreader* #'unreader)) (flet ((next-char () (code-char (octets-to-char-code external-format reader)))) (declare (inline next-char)) (etypecase factor (integer (let* ((string-length (ceiling length factor)) (string (make-array string-length :element-type 'char*))) (declare (fixnum string-length)) (loop for j of-type fixnum from 0 below string-length do (setf (schar string j) (next-char)) finally (return string)))) (double-float ;; this is a bit clunky but hopefully a bit more efficient than ;; using VECTOR-PUSH-EXTEND (let* ((string-length (ceiling length (the double-float factor))) (string (make-array string-length :element-type 'char* :fill-pointer t :adjustable t)) (j 0)) (declare (fixnum j string-length) (double-float factor)) (loop (when (>= i end) (return)) (when (>= j string-length) (setq factor (/ factor 2.0d0)) (incf string-length (the fixnum (ceiling (- end i) factor))) (adjust-array string string-length :fill-pointer t)) (setf (char string j) (next-char)) (incf j)) (setf (fill-pointer string) j) string)))))))) (defun octet-length (string &key (external-format :latin1) (start 0) (end (length string))) "Returns the length of the substring of STRING from START to END in octets if encoded using the external format EXTERNAL-FORMAT. Might return NIL if there's no efficient way to compute the length without iterating through the whole string." (declare #.*standard-optimize-settings*) (declare (fixnum start end) (string string)) (setq external-format (maybe-convert-external-format external-format)) (let ((factor (encoding-factor external-format))) (typecase factor (fixnum (* factor (- end start))))))