From 7fad9c10510187764a6afbe0ac070a68011278b8 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 5 Jul 2003 02:32:31 +0000 Subject: [PATCH] r5238: *** empty log message *** --- byte-stream.lisp | 230 +++++++++++++++++++++++++++++++++++++++++++++++ console.lisp | 8 +- lists.lisp | 9 +- package.lisp | 9 +- 4 files changed, 242 insertions(+), 14 deletions(-) create mode 100644 byte-stream.lisp diff --git a/byte-stream.lisp b/byte-stream.lisp new file mode 100644 index 0000000..36f77e7 --- /dev/null +++ b/byte-stream.lisp @@ -0,0 +1,230 @@ +;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: byte-stream.lisp +;;;; Purpose: Byte array input/output streams +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: June 2003 +;;;; +;;;; $Id: byte-stream.lisp,v 1.1 2003/07/05 02:32:08 kevin Exp $ +;;;; +;;;; Works for CMUCL, SBCL, and AllergoCL only +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg +;;;; and by onShore Development, Inc. +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +#+(or cmu sbcl) +(progn +(defstruct (byte-array-output-stream + (:include #+cmu system:lisp-stream + #+sbcl sb-impl::file-stream + (bout #'byte-array-bout) + (misc #'byte-array-out-misc)) + (:print-function %print-byte-array-output-stream) + (:constructor make-byte-array-output-stream ())) + ;; The buffer we throw stuff in. + (buffer (make-array 128 :element-type '(unsigned-byte 8))) + ;; Index of the next location to use. + (index 0 :type fixnum)) + +(defun %print-byte-array-output-stream (s stream d) + (declare (ignore s d)) + (write-string "#" stream)) + +(setf (documentation 'make-binary-output-stream 'function) + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-Data.") + +(defun byte-array-bout (stream byte) + (let ((current (byte-array-output-stream-index stream)) + (workspace (byte-array-output-stream-buffer stream))) + (if (= current (length workspace)) + (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8)))) + (replace new-workspace workspace) + (setf (aref new-workspace current) byte) + (setf (byte-array-output-stream-buffer stream) new-workspace)) + (setf (aref workspace current) byte)) + (setf (byte-array-output-stream-index stream) (1+ current)))) + +(defun byte-array-out-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:file-position + (if (null arg1) + (byte-array-output-stream-index stream))) + (:element-type '(unsigned-byte 8)))) + +(defun get-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function and +clears buffer." + (declare (type byte-array-output-stream stream)) + (prog1 + (dump-output-stream-data stream) + (setf (byte-array-output-stream-index stream) 0))) + +(defun dump-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function." + (declare (type byte-array-output-stream stream)) + (let* ((length (byte-array-output-stream-index stream)) + (result (make-array length :element-type '(unsigned-byte 8)))) + (replace result (byte-array-output-stream-buffer stream)) + result)) + +) ; progn + + +#+(or cmu sbcl) +(progn + (defstruct (byte-array-input-stream + (:include #+cmu system:lisp-stream + #+sbcl sb-impl::file-stream + (in #'byte-array-inch) + (bin #'byte-array-binch) + (n-bin #'byte-array-stream-read-n-bytes) + (misc #'byte-array-in-misc)) + (:print-function %print-byte-array-input-stream) + ;(:constructor nil) + (:constructor internal-make-byte-array-input-stream + (byte-array current end))) + (byte-array nil :type vector) + (current nil) + (end nil)) + +(defun %print-byte-array-input-stream (s stream d) + (declare (ignore s d)) + (write-string "#" stream)) + +(defun byte-array-inch (stream eof-errorp eof-value) + (let ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream))) + (cond ((= index (byte-array-input-stream-end stream)) + (eof-or-lose stream eof-errorp eof-value)) + (t + (setf (byte-array-input-stream-current stream) (1+ index)) + (aref byte-array index))))) + +(defun byte-array-binch (stream eof-errorp eof-value) + (let ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream))) + (cond ((= index (byte-array-input-stream-end stream)) + (eof-or-lose stream eof-errorp eof-value)) + (t + (setf (byte-array-input-stream-current stream) (1+ index)) + (aref byte-array index))))) + +(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp) + (declare (type byte-array-input-stream stream)) + (let* ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream)) + (available (- (byte-array-input-stream-end stream) index)) + (copy (min available requested))) + (when (plusp copy) + (setf (byte-array-input-stream-current stream) + (+ index copy)) + #+cmu + (system:without-gcing + (system::system-area-copy (system:vector-sap byte-array) + (* index vm:byte-bits) + (if (typep buffer 'system::system-area-pointer) + buffer + (system:vector-sap buffer)) + (* start vm:byte-bits) + (* copy vm:byte-bits))) + #+sbcl + (sb-sys:without-gcing + (sb-kernel:system-area-copy (sb-sys:vector-sap byte-array) + (* index sb-vm:n-byte-bits) + (if (typep buffer 'sb-sys::system-area-pointer) + buffer + (sb-sys:vector-sap buffer)) + (* start sb-vm:n-byte-bits) + (* copy sb-vm:n-byte-bits)))) + (if (and (> requested copy) eof-errorp) + (error 'end-of-file :stream stream) + copy))) + +(defun byte-array-in-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:file-position + (if arg1 + (setf (byte-array-input-stream-current stream) arg1) + (byte-array-input-stream-current stream))) + (:file-length (length (byte-array-input-stream-byte-array stream))) + (:unread (decf (byte-array-input-stream-current stream))) + (:listen (or (/= (the fixnum (byte-array-input-stream-current stream)) + (the fixnum (byte-array-input-stream-end stream))) + :eof)) + (:element-type 'base-char))) + +(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer))) + "Returns an input stream which will supply the bytes of BUFFER between + Start and End in order." + (internal-make-byte-array-input-stream buffer start end)) + +) ;; progn + +#+allegro +(progn + + (defclass extendable-buffer-output-stream (excl:buffer-output-simple-stream) + () + ) + + (defun make-byte-array-output-stream () + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-Data." + (make-instance 'extendable-buffer-output-stream + :buffer (make-array 128 :element-type '(unsigned-byte 8)) + :external-form :octets)) + + (defun get-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function +and clears buffer." + (prog1 + (dump-output-stream-data stream) + (file-position stream 0))) + + (defun dump-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function." + (force-output stream) + (let* ((length (file-position stream)) + (result (make-array length :element-type '(unsigned-byte 8)))) + (replace result (slot-value stream 'excl::buffer)) + result)) + + (defmethod excl:device-extend ((stream extendable-buffer-output-stream) + need action) + (let* ((len (file-position stream)) + (new-len (max (+ len need) (* 2 len))) + (old-buf (slot-value stream 'excl::buffer)) + (new-buf (make-array new-len :element-type '(unsigned-byte 8)))) + (declare (fixnum len) + (optimize (speed 3) (safety 0))) + (dotimes (i len) + (setf (aref new-buf i) (aref old-buf i))) + (setf (slot-value stream 'excl::buffer) new-buf) + (setf (slot-value stream 'excl::buffer-ptr) new-len) + ) + t) + +) + +#+allegro +(progn + (defun make-byte-array-input-stream (buffer &optional (start 0) + (end (length buffer))) + (excl:make-buffer-input-stream buffer start end :octets)) + ) ;; progn diff --git a/console.lisp b/console.lisp index 77922d1..e45abf3 100644 --- a/console.lisp +++ b/console.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -7,8 +7,8 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: console.lisp,v 1.3 2003/07/01 22:16:40 kevin Exp $ -;;;; +;;;; $Id: console.lisp,v 1.4 2003/07/05 02:32:08 kevin Exp $ +;;;;a ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and by onShore Development, Inc. ;;;; @@ -17,7 +17,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) (defvar *console-msgs* t) diff --git a/lists.lisp b/lists.lisp index 8bc548d..285bb39 100644 --- a/lists.lisp +++ b/lists.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: lists.lisp,v 1.7 2003/06/20 08:35:22 kevin Exp $ +;;;; $Id: lists.lisp,v 1.8 2003/07/05 02:32:08 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -176,11 +176,4 @@ ,plist) (setf ,plist (append ,plist (list ,pkey ,value))))))) -(defun get-plist (key plist &key (test 'eql) (missing nil)) - (let-if (pos (member key plist :test test)) - (cadr pos) - missing)) -(defun (setf get-plist) (value key plist &key (test #'eql)) - (update-plist key value plist :test test) - value) diff --git a/package.lisp b/package.lisp index bd4d11d..f45be55 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.44 2003/06/20 08:35:22 kevin Exp $ +;;;; $Id: package.lisp,v 1.45 2003/07/05 02:32:31 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -196,7 +196,12 @@ #:cmsg-add #:cmsg-remove #:fixme - + + ;; byte-stream + #:make-binary-array-output-stream + #:get-output-stream-data + #:dump-output-stream-data + #:make-byte-array-input-stream )) -- 2.34.1