Newer
Older
;;; **********************************************************************
;;; 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.105 2010/07/02 16:29:55 rtoy Exp $")
;;; **********************************************************************
;;;
;;; Streams for UNIX file descriptors.
;;;
;;; Written by William Lott, July 1989 - January 1990.
;;; Some tuning by Rob MacLachlan.
;;;
;;; **********************************************************************
(in-package "SYSTEM")
(intl:textdomain "cmucl")
io-timeout beep *beep-function* output-raw-bytes
*tty* *stdin* *stdout* *stderr*
binary-text-stream))
(in-package "EXTENSIONS")
(export '(*backup-extension*))
(in-package "LISP")
(export '(file-stream file-string-length))
;;;; Buffer manipulation routines.
(defvar *available-buffers* ()
"List of available buffers. Each buffer is an sap pointing to
bytes-per-buffer of memory.")
(defvar lisp::*enable-stream-buffer-p* nil)
"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.")
;;; Returns the next available buffer, creating one if necessary.
;;;
(defun next-available-buffer ()
(if *available-buffers*
(pop *available-buffers*)
(allocate-system-memory bytes-per-buffer)))
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
(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)
(otherwise endian-swap)))
;;;; Superclass defined by the ANSI Spec
(defstruct (file-stream
(:include lisp-stream)
(:constructor nil)
(:copier nil)))
(defstruct (fd-stream
(:print-function %print-fd-stream)
(:constructor %make-fd-stream)
(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))
;;
;;; Number of bytes per element.
Loading
Loading full blame...