;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/flexi-streams/encode.lisp,v 1.12 2008/05/20 23:01:50 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)

(defgeneric char-to-octets (format char writer)
  (declare #.*standard-optimize-settings*)
  (:documentation "Converts the character CHAR to a sequence of octets
using the external format FORMAT.  The conversion is performed by
calling the unary function \(which must be a functional object) WRITER
repeatedly each octet.  The return value of this function is
unspecified."))

(defmethod char-to-octets ((format flexi-latin-1-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (let ((octet (char-code char)))
    (when (> octet 255)
      (signal-encoding-error format "~S (code ~A) is not a LATIN-1 character." char octet))
    (funcall writer octet)))

(defmethod char-to-octets ((format flexi-ascii-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (let ((octet (char-code char)))
    (when (> octet 127)
      (signal-encoding-error format "~S (code ~A) is not an ASCII character." char octet))
    (funcall writer octet)))

(defmethod char-to-octets ((format flexi-8-bit-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (with-accessors ((encoding-hash external-format-encoding-hash))
      format
    (let ((octet (gethash (char-code char) encoding-hash)))
      (unless octet
        (signal-encoding-error format "~S (code ~A) is not in this encoding." char octet))
      (funcall writer octet))))

(defmethod char-to-octets ((format flexi-utf-8-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (let ((char-code (char-code char)))
    (tagbody
     (cond ((< char-code #x80)
            (funcall writer char-code)
            (go zero))
           ((< char-code #x800)
            (funcall writer (logior #b11000000 (ldb (byte 5 6) char-code)))
            (go one))
           ((< char-code #x10000)
            (funcall writer (logior #b11100000 (ldb (byte 4 12) char-code)))
            (go two))
           ((< char-code #x200000)
            (funcall writer (logior #b11110000 (ldb (byte 3 18) char-code)))
            (go three))
           ((< char-code #x4000000)
            (funcall writer (logior #b11111000 (ldb (byte 2 24) char-code)))
            (go four))
           (t (funcall writer (if (logbitp 30 char-code) #b11111101 #b11111100))))
     (funcall writer (logior #b10000000 (ldb (byte 6 24) char-code)))
     four
     (funcall writer (logior #b10000000 (ldb (byte 6 18) char-code)))
     three
     (funcall writer (logior #b10000000 (ldb (byte 6 12) char-code)))
     two
     (funcall writer (logior #b10000000 (ldb (byte 6 6) char-code)))
     one
     (funcall writer (logior #b10000000 (ldb (byte 6 0) char-code)))
     zero)))

(defmethod char-to-octets ((format flexi-utf-16-le-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (flet ((write-word (word)
           (funcall writer (ldb (byte 8 0) word))
           (funcall writer (ldb (byte 8 8) word))))
    (declare (inline write-word))
    (let ((char-code (char-code char)))
      (declare (type char-code-integer char-code))
      (cond ((< char-code #x10000)
             (write-word char-code))
            (t (decf char-code #x10000)
               (write-word (logior #xd800 (ldb (byte 10 10) char-code)))
               (write-word (logior #xdc00 (ldb (byte 10 0) char-code))))))))

(defmethod char-to-octets ((format flexi-utf-16-be-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (flet ((write-word (word)
           (funcall writer (ldb (byte 8 8) word))
           (funcall writer (ldb (byte 8 0) word))))
    (declare (inline write-word))
    (let ((char-code (char-code char)))
      (declare (type char-code-integer char-code))
      (cond ((< char-code #x10000)
             (write-word char-code))
            (t (decf char-code #x10000)
               (write-word (logior #xd800 (ldb (byte 10 10) char-code)))
               (write-word (logior #xdc00 (ldb (byte 10 0) char-code))))))))

(defmethod char-to-octets ((format flexi-utf-32-le-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (let ((char-code (char-code char)))
    (funcall writer (ldb (byte 8 0) char-code))
    (funcall writer (ldb (byte 8 8) char-code))
    (funcall writer (ldb (byte 8 16) char-code))
    (funcall writer (ldb (byte 8 24) char-code))))

(defmethod char-to-octets ((format flexi-utf-32-be-format) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char) (function writer))
  (let ((char-code (char-code char)))
    (funcall writer (ldb (byte 8 24) char-code))
    (funcall writer (ldb (byte 8 16) char-code))
    (funcall writer (ldb (byte 8 8) char-code))
    (funcall writer (ldb (byte 8 0) char-code))))

(defmethod char-to-octets ((format flexi-cr-mixin) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char))
  (if (char= char #\Newline)
    (call-next-method format #\Return writer)
    (call-next-method)))

(defmethod char-to-octets ((format flexi-crlf-mixin) char writer)
  (declare #.*fixnum-optimize-settings*)
  (declare (character char))
  (cond ((char= char #\Newline)
         (call-next-method format #\Return writer)
         (call-next-method format #\Linefeed writer))
        (t (call-next-method))))