Skip to content
Snippets Groups Projects
classes.lisp 8.85 KiB
Newer Older
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
;;; 
(ext:file-comment
 "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.6 2007/11/05 15:25:04 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
;;; Base class and generic function definitions for simple-streams

(in-package "STREAM")

(eval-when (:compile-toplevel)
  (pushnew 'compile pcl::*defclass-times*)
  (pushnew 'compile pcl::*defgeneric-times*))


;;;; Types for buffer and strategy functions

;;(deftype simple-stream-buffer ()
;;  '(or sys:system-area-pointer (kernel:simple-unboxed-array (*))))

(deftype blocking ()
  `(member t nil :bnb))

(deftype j-listen-fn ()
  '(function (simple-stream) boolean))

(deftype j-read-char-fn ()
  '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE

(deftype j-read-chars-fn ()
  '(function (simple-stream string (or character null) fixnum fixnum blocking)
	     (values fixnum &optional (member nil t :eof))))

(deftype j-write-char-fn ()
  '(function ((or character null) simple-stream) (or character null)))

(deftype j-write-chars-fn ()
  '(function (string simple-stream fixnum fixnum) t)) ; return chars-written?

(deftype j-unread-char-fn ()
  '(function (simple-stream t) t)) ; "relaxed" arg is boolean?  what return?

;;;; Base simple-stream classes

(def-stream-class simple-stream (standard-object stream)
  ((%flags :initform 0 :type fixnum)
   (plist :initform nil :type list :accessor stream-plist)

   (j-listen :initform #'lisp::ill-in-any :type j-listen-fn)
   (j-read-char :initform #'lisp::ill-in-any :type j-read-char-fn)
   (j-read-chars :initform #'lisp::ill-in-any :type j-read-chars-fn)
   (j-unread-char :initform #'lisp::ill-in-any :type j-unread-char-fn)
   (j-write-char :initform #'lisp::ill-out-any :type j-write-char-fn) ;@@
   (j-write-chars :initform #'lisp::ill-out-any :type j-write-chars-fn) ;@@
toy's avatar
toy committed
   (oc-state :initform nil)
   (co-state :initform nil)
   (external-format :initform (find-external-format :default))

   (input-handle :initform nil :initarg :input-handle
		 :type (or null fixnum stream)
		 :accessor stream-input-handle)
   (output-handle :initform nil :initarg :output-handle
		  :type (or null fixnum stream)
		  :accessor stream-output-handle)
   (control-in :initform nil :type (or null simple-vector))
   (control-out :initform nil :type (or null simple-vector))

   (melded-stream :type (or null simple-stream))
   (melding-base :type (or null simple-stream))

   (encapsulated-char-read-size :initform 0 :type fixnum)
   (last-char-read-size :initform 0 :type fixnum)
   (charpos :initform 0 :type (or null integer)
	    :accessor stream-line-column)
toy's avatar
toy committed
   (record-end :initform nil :type (or null fixnum))
   (buffer :initform nil :type (or kernel:simple-stream-buffer null))
   (buffpos :initform 0 :type fixnum)
   (buffer-ptr :initform 0 :type fixnum)
toy's avatar
toy committed
   (buf-len :initform 0 :type fixnum)

   (pending :initform nil :type list)
   (handler :initform nil :type (or null lisp::handler))))

(def-stream-class single-channel-simple-stream (simple-stream)
  ((mode :initform 0 :type fixnum)))

(def-stream-class dual-channel-simple-stream (simple-stream)
  ((out-buffer :initform nil :type (or kernel:simple-stream-buffer null))
   (outpos :initform 0 :type fixnum)
   (max-out-pos :initform 0 :type fixnum)
   (mode :initform 0 :type fixnum)))

(def-stream-class string-simple-stream (simple-stream)


;;;; Generic function definitions

(defgeneric device-open (stream options)
  (:documentation "Write me"))

(defgeneric device-close (stream abort)
  (:documentation "Write me"))

(defgeneric device-buffer-length (stream)
  (:documentation "Write me"))

(defgeneric device-file-position (stream)
  (:documentation "Write me"))

(defgeneric (setf device-file-position) (value stream)
  (:argument-precedence-order stream value)
  (:documentation "Write me"))

(defgeneric device-file-length (stream)
  (:documentation "Write me"))

(defgeneric device-read (stream buffer start end blocking)
  (:documentation "Write me"))

(defgeneric device-clear-input (stream buffer-only)
  (:documentation "Write me"))

(defgeneric device-write (stream buffer start end blocking)
  (:documentation "Write me"))

(defgeneric device-clear-output (stream)
  (:documentation "Write me"))

(defgeneric device-finish-record (stream blocking action)
  (:documentation "Write me"))


(defmethod shared-initialize :after ((instance simple-stream) slot-names
				     &rest initargs &key &allow-other-keys)
  (declare (ignore slot-names))
  (unless (slot-boundp instance 'melded-stream)
    (setf (slot-value instance 'melded-stream) instance)
    (setf (slot-value instance 'melding-base) instance))
  (unless (device-open instance initargs)
    (device-close instance t)))

(defmethod print-object ((object simple-stream) stream)
  (print-unreadable-object (object stream :type nil :identity nil)
    (cond ((not (any-stream-instance-flags object :simple))
	   (princ "Invalid " stream))
	  ((not (any-stream-instance-flags object :input :output))
	   (princ "Closed " stream)))
    (format stream "~:(~A~)" (type-of object))))

(defmethod device-close :around ((stream simple-stream) abort)
  (with-stream-class (simple-stream stream)
    (when (any-stream-instance-flags stream :input :output)
      (when (any-stream-instance-flags stream :output)
toy's avatar
toy committed
	(ignore-errors (if abort
			   (clear-output stream)
			   (finish-output stream))))
      (call-next-method)
      (setf (sm input-handle stream) nil
toy's avatar
toy committed
	    (sm output-handle stream) nil)
      (remove-stream-instance-flags stream :input :output)
toy's avatar
toy committed
      (ext:cancel-finalization stream)
      (setf (stream-external-format stream) :void))))

(defmethod device-close ((stream simple-stream) abort)
  (declare (ignore abort))
  t)

(defmethod device-buffer-length ((stream simple-stream))
  4096)

(defmethod device-file-position ((stream simple-stream))
  (with-stream-class (simple-stream stream)
toy's avatar
toy committed
    (sm buffpos stream)))

(defmethod (setf device-file-position) (value (stream simple-stream))
  (with-stream-class (simple-stream stream)
toy's avatar
toy committed
    (setf (sm buffpos stream) value)))

(defmethod device-file-length ((stream simple-stream))
  nil)

toy's avatar
toy committed
(defmethod (setf stream-external-format) :before (value (stream simple-stream))
  ;; (unless (eq value (sm external-format stream))
  ;;   flush out the existing external-format
  )

(defmethod (setf stream-external-format) :after
    (value (stream single-channel-simple-stream))
  (compose-encapsulating-streams stream value)
  (install-single-channel-character-strategy (melding-stream stream)
					     value nil))

(defmethod (setf stream-external-format) :after
    (value (stream dual-channel-simple-stream))
  (compose-encapsulating-streams stream value)
  (install-dual-channel-character-strategy (melding-stream stream) value))


(defmethod device-read ((stream single-channel-simple-stream) buffer
                        start end blocking)
  (read-octets stream buffer start end blocking))

(defmethod device-read ((stream dual-channel-simple-stream) buffer
                        start end blocking)
  (read-octets stream buffer start end blocking))

(defmethod device-clear-input ((stream simple-stream) buffer-only)
  (declare (ignore buffer-only))
  nil)

(defmethod device-write ((stream single-channel-simple-stream) buffer
                         start end blocking)
toy's avatar
toy committed
  ;; buffer may be :flush to force/finish-output
  (when (or (and (null buffer) (not (eql start end)))
	    (eq buffer :flush))
    (with-stream-class (single-channel-simple-stream stream)
      (setf buffer (sm buffer stream))
      (setf end (sm buffpos stream))))
  (write-octets stream buffer start end blocking))

(defmethod device-write ((stream dual-channel-simple-stream) buffer
                         start end blocking)
toy's avatar
toy committed
  ;; buffer may be :flush to force/finish-output
  (when (or (and (null buffer) (not (eql start end)))
	    (eq buffer :flush))
    (with-stream-class (dual-channel-simple-stream stream)
      (setf buffer (sm out-buffer stream))
      (setf end (sm outpos stream))))
  (write-octets stream buffer start end blocking))

(defmethod device-clear-output ((stream simple-stream))
  nil)


;;;; Fixups when Gray streams support is present

(when (find-class 'ext:fundamental-stream nil)
  (defmethod stream-element-type ((stream stream:simple-stream))
    '(unsigned-byte 8))
  (defmethod open-stream-p ((stream stream:simple-stream))
    (any-stream-instance-flags stream :input :output))
  (defmethod close ((stream stream:simple-stream) &key abort)
    (stream:device-close stream abort))
  (defmethod input-stream-p ((stream stream:simple-stream))
    (any-stream-instance-flags stream :input))
  (defmethod output-stream-p ((stream stream:simple-stream))
    (any-stream-instance-flags stream :output))
) ; WHEN