Skip to content
Snippets Groups Projects
fd-stream.lisp 77.6 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Log: code.log; Package: LISP -*-
ram's avatar
ram committed
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.90 2009/08/26 16:25:41 rtoy Exp $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;; Streams for UNIX file descriptors.
;;;
;;; Written by William Lott, July 1989 - January 1990.
;;; Some tuning by Rob MacLachlan.
ram's avatar
ram committed
;;; 
;;; **********************************************************************


(in-package "SYSTEM")

(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
          io-timeout beep *beep-function* output-raw-bytes
	  *tty* *stdin* *stdout* *stderr*
	  binary-text-stream))
ram's avatar
ram committed


(in-package "EXTENSIONS")

(export '(*backup-extension*))


(in-package "LISP")

(export '(file-stream file-string-length))
ram's avatar
ram committed

;;;; Buffer manipulation routines.

(defvar *available-buffers* ()
  "List of available buffers.  Each buffer is an sap pointing to
  bytes-per-buffer of memory.")
ram's avatar
ram committed

(defconstant bytes-per-buffer (* 4 1024)
  "Number of bytes per buffer.")

;; This limit is rather arbitrary
(defconstant max-stream-element-size 1024
  "The maximum supported byte size for a stream element-type.")

ram's avatar
ram committed
;;; NEXT-AVAILABLE-BUFFER -- Internal.
;;;
;;; Returns the next available buffer, creating one if necessary.
ram's avatar
ram committed
;;;
pw's avatar
pw committed
(declaim (inline next-available-buffer))
ram's avatar
ram committed
;;;
(defun next-available-buffer ()
  (if *available-buffers*
      (pop *available-buffers*)
      (allocate-system-memory bytes-per-buffer)))
ram's avatar
ram committed

(declaim (inline buffer-sap bref (setf bref) buffer-copy))

(defun buffer-sap (thing &optional offset)
  (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
           (optimize (speed 3) (space 2) (debug 0) (safety 0)
                     ;; Suppress the note about having to box up the return:
                     (ext:inhibit-warnings 3)))
  (let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
    (if offset (sys:sap+ sap offset) sap)))

(defun bref (buffer index)
  (declare (type simple-stream-buffer buffer)
           (type (integer 0 #.most-positive-fixnum) index))
  (sys:sap-ref-8 (buffer-sap buffer) index))

(defun (setf bref) (octet buffer index)
  (declare (type (unsigned-byte 8) octet)
           (type simple-stream-buffer buffer)
           (type (integer 0 #.most-positive-fixnum) index))
  (setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))

(defun buffer-copy (src soff dst doff length)
  (declare (type simple-stream-buffer src dst)
           (type fixnum soff doff length))
  (sys:without-gcing ;; is this necessary??
   (kernel:system-area-copy (buffer-sap src) (* soff 8)
                            (buffer-sap dst) (* doff 8)
                            (* length 8))))

#-(or big-endian little-endian)
(eval-when (:compile-toplevel)
  (push (c::backend-byte-order c::*target-backend*) *features*))

(defun vector-elt-width (vector)
  ;; Return octet-width of vector elements
  (etypecase vector
    ;; (simple-array fixnum (*)) not supported
    ;; (simple-array base-char (*)) treated specially; don't call this
    ((simple-array bit (*)) 1/8)
    ((simple-array (unsigned-byte 2) (*)) 1/4)
    ((simple-array (unsigned-byte 4) (*)) 1/2)
    ((simple-array (signed-byte 8) (*)) 1)
    ((simple-array (unsigned-byte 8) (*)) 1)
    ((simple-array (signed-byte 16) (*)) 2)
    ((simple-array (unsigned-byte 16) (*)) 2)
    ((simple-array (signed-byte 32) (*)) 4)
    ((simple-array (unsigned-byte 32) (*)) 4)
    ((simple-array single-float (*)) 4)
    ((simple-array double-float (*)) 8)
    ((simple-array (complex single-float) (*)) 8)
    ((simple-array (complex double-float) (*)) 16)
    #+long-float
    ((simple-array long-float (*)) 10)
    #+long-float
    ((simple-array (complex long-float) (*)) 20)
    #+double-double
    ((simple-array double-double-float (*)) 16)
    #+double-double
    ((simple-array (complex double-double-float) (*)) 32)))

(defun endian-swap-value (vector endian-swap)
  (case endian-swap
    (:network-order
     #+big-endian 0
     ;; This is needed because the little-endian (x86) architectures
     ;; store the lowest indexed element in the least significant part
     ;; of a byte.  On a big-endian machine (sparc, ppc), the lowest
     ;; indexed element is at the most significant part of a byte.
     #+little-endian
     (typecase vector
       ((array (unsigned-byte 4) (*))
	-1)
       ((array (unsigned-byte 2) (*))
	-2)
       ((array (unsigned-byte 1) (*))
	-8)
       (t
	(1- (vector-elt-width vector)))))
    (:byte-8 0)
    (:byte-16 1)
    (:byte-32 3)
    (:byte-64 7)
    (:byte-128 15)
    ;; additions by Lynn Quam
    (:machine-endian 0)
    (:big-endian
     #+big-endian 0
     #+little-endian
     (typecase vector
       ((array (unsigned-byte 4) (*))
	-1)
       ((array (unsigned-byte 2) (*))
	-2)
       ((array (unsigned-byte 1) (*))
	-8)
       (t
	(1- (vector-elt-width vector)))))
    (:little-endian
     #+big-endian
     (typecase vector
       ((array (unsigned-byte 4) (*))
	-1)
       ((array (unsigned-byte 2) (*))
	-2)
       ((array (unsigned-byte 1) (*))
	-8)
       (t
	(1- (vector-elt-width vector))))
     #+little-endian 0)
ram's avatar
ram committed

;;;; The FD-STREAM structure.

moore's avatar
 
moore committed
;;;; Superclass defined by the ANSI Spec
(defstruct (file-stream
	     (:include lisp-stream)
	     (:constructor nil)
	     (:copier nil)))

ram's avatar
ram committed
(defstruct (fd-stream
	    (:print-function %print-fd-stream)
	    (:constructor %make-fd-stream)
moore's avatar
 
moore committed
	    (:include file-stream
ram's avatar
ram committed
		      (misc #'fd-stream-misc-routine)))

  (name nil)		      ; The name of this stream
  (file nil)		      ; The file this stream is for
  ;;
  ;; The backup file namestring for the old file, for :if-exists :rename or
  ;; :rename-and-delete.
  (original nil :type (or simple-string null))
ram's avatar
ram committed
  (delete-original nil)	      ; for :if-exists :rename-and-delete
  ;;
  ;;; Number of bytes per element.
  (element-size 1 :type index)
  (element-type 'base-char)   ; The type of element being transfered.
ram's avatar
ram committed
  (fd -1 :type fixnum)	      ; The file descriptor
Loading
Loading full blame...