From ddb83b1fb2d305e0c06fc067d82d6bab5458b0fd Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 30 Oct 2009 20:52:07 +0100 Subject: Add third-party XML processing libraries. Ignore-this: 5ca28497555bf944858ca2f58bc8a62b darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c --- third-party/s-sysdeps/src/bivalent-streams.lisp | 107 ++++++++++++++++++++++++ 1 file changed, 107 insertions(+) create mode 100644 third-party/s-sysdeps/src/bivalent-streams.lisp (limited to 'third-party/s-sysdeps/src/bivalent-streams.lisp') diff --git a/third-party/s-sysdeps/src/bivalent-streams.lisp b/third-party/s-sysdeps/src/bivalent-streams.lisp new file mode 100644 index 0000000..3261a50 --- /dev/null +++ b/third-party/s-sysdeps/src/bivalent-streams.lisp @@ -0,0 +1,107 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $ +;;;; +;;;; Bivalent streams for CLISP +;;;; +;;;; Copyright (C) 2007 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-sysdeps) + +;;; Rationale: + +;;; we want (socket) streams that support input and output (i.e. are bidirectional), +;;; using bytes and characters (i.e. are bivalent) at the same time, with conversions +;;; using a straight/native byte to character conversion + +;;; this is an (incomplete) implementation for CLISP based on Gray streams +;;; in other words: this is a hack to fix a particular problem/situation + +(defclass bivalent-bidirectional-stream (gray:fundamental-character-input-stream + gray:fundamental-character-output-stream + gray:fundamental-binary-input-stream + gray:fundamental-binary-output-stream) + ((bidirectional-binary-stream :reader get-native-stream :initarg :bidirection-binary-stream))) + +(defun make-bivalent-stream (stream) + "Wrap a bidirectional binary stream so that it behaves as a bivalent bidirectional stream" + (make-instance 'bivalent-bidirectional-stream :bidirection-binary-stream stream)) + +;;; minimal required methods + +(defmethod stream-element-type ((stream bivalent-bidirectional-stream)) + '(or character (unsigned-byte 8))) + +(defmethod close ((stream bivalent-bidirectional-stream) &key abort) + (close (get-native-stream stream) :abort abort) + (call-next-method)) + +(defmethod gray:stream-position ((stream bivalent-bidirectional-stream) position) + (gray:stream-position (get-native-stream stream) position)) + +(defmethod gray:stream-read-char ((stream bivalent-bidirectional-stream)) + (code-char (read-byte (get-native-stream stream)))) + +#+nil +(defmethod gray:stream-unread-char ((stream bivalent-bidirectional-stream))) + +(defmethod gray:stream-write-char ((stream bivalent-bidirectional-stream) char) + (write-byte (char-code char) (get-native-stream stream))) + +(defmethod gray:stream-line-column ((stream bivalent-bidirectional-stream)) + nil) + +(defmethod gray:stream-finish-output ((stream bivalent-bidirectional-stream)) + (finish-output (get-native-stream stream))) + +(defmethod gray:stream-force-output ((stream bivalent-bidirectional-stream)) + (force-output (get-native-stream stream))) + +(defmethod gray:stream-read-byte ((stream bivalent-bidirectional-stream)) + (read-byte (get-native-stream stream))) + +(defmethod gray:stream-read-byte-lookahead ((stream bivalent-bidirectional-stream)) + (ext:read-byte-lookahead (get-native-stream stream))) + +(defmethod gray:stream-write-byte ((stream bivalent-bidirectional-stream) byte) + (write-byte byte (get-native-stream stream))) + +;;; 'optimized' sequence IO + +(defmethod gray:stream-read-char-sequence ((stream bivalent-bidirectional-stream) sequence + &optional start end) + (unless start (setf start 0)) + (unless end (setf end (length sequence))) + (let* ((byte-buffer (make-array (- end start) :element-type '(unsigned-byte 8))) + (result (ext:read-byte-sequence byte-buffer (get-native-stream stream)))) + (loop :for i :from start :below (min end result) + :do (setf (elt sequence (+ start i)) (code-char (elt byte-buffer i)))) + (+ start result))) + +(defmethod gray:stream-write-char-sequence ((stream bivalent-bidirectional-stream) sequence + &optional start end) + (unless start (setf start 0)) + (unless end (setf end (length sequence))) + (let ((byte-buffer (make-array (- end start) :element-type '(unsigned-byte 8)))) + (loop :for i :from start :below (- end start) + :do (setf (elt byte-buffer i) (char-code (elt sequence (+ start i))))) + (multiple-value-bind (seq result) + (ext:write-byte-sequence byte-buffer (get-native-stream stream)) + (declare (ignore seq)) + (+ start result)))) + +(defmethod gray:stream-read-byte-sequence ((stream bivalent-bidirectional-stream) sequence + &optional start end no-hang interactive) + (declare (ignore no-hang interactive)) + (ext:read-byte-sequence sequence (get-native-stream stream) :start start :end end)) + +(defmethod gray:stream-write-byte-sequence ((stream bivalent-bidirectional-stream) sequence + &optional start end no-hang interactive) + (declare (ignore no-hang interactive)) + (ext:write-byte-sequence sequence (get-native-stream stream) :start start :end end)) + +;;;; eof -- cgit v1.2.3