Skip to content
Snippets Groups Projects
Commit f4b6d8f4 authored by dtc's avatar dtc
Browse files

Rework the code to allow file offsets greater than the most positive

fixnum which was only around 500Meg, as noted by Martin Cracauer.
parent bfbe4f7e
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.50 1999/12/04 16:02:34 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.51 2000/06/19 16:08:38 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -207,7 +207,7 @@ ...@@ -207,7 +207,7 @@
) )
(let ((length (- end start))) (let ((length (- end start)))
(multiple-value-bind (multiple-value-bind
(count errno) (count errno)
(unix:unix-write (fd-stream-fd stream) base start length) (unix:unix-write (fd-stream-fd stream) base start length)
(cond ((not count) (cond ((not count)
(if (= errno unix:ewouldblock) (if (= errno unix:ewouldblock)
...@@ -399,7 +399,7 @@ ...@@ -399,7 +399,7 @@
(defun fd-sout (stream thing start end) (defun fd-sout (stream thing start end)
(let ((start (or start 0)) (let ((start (or start 0))
(end (or end (length (the vector thing))))) (end (or end (length (the vector thing)))))
(declare (fixnum start end)) (declare (type index start end))
(if (stringp thing) (if (stringp thing)
(let ((last-newline (and (find #\newline (the simple-string thing) (let ((last-newline (and (find #\newline (the simple-string thing)
:start start :end end) :start start :end end)
...@@ -1033,9 +1033,9 @@ ...@@ -1033,9 +1033,9 @@
(error "Error fstating ~S: ~A" (error "Error fstating ~S: ~A"
stream stream
(unix:get-unix-error-msg dev))) (unix:get-unix-error-msg dev)))
(if (zerop (the index mode)) (if (zerop mode)
nil nil
(truncate (the index size) (fd-stream-element-size stream))))) (truncate size (fd-stream-element-size stream)))))
(:file-position (:file-position
(fd-stream-file-position stream arg1)))) (fd-stream-file-position stream arg1))))
...@@ -1044,16 +1044,15 @@ ...@@ -1044,16 +1044,15 @@
;;; ;;;
(defun fd-stream-file-position (stream &optional newpos) (defun fd-stream-file-position (stream &optional newpos)
(declare (type fd-stream stream) (declare (type fd-stream stream)
(type (or index (member nil :start :end)) newpos)) (type (or (integer 0) (member nil :start :end)) newpos))
(if (null newpos) (if (null newpos)
(system:without-interrupts (system:without-interrupts
;; First, find the position of the UNIX file descriptor in the ;; First, find the position of the UNIX file descriptor in the file.
;; file.
(multiple-value-bind (multiple-value-bind
(posn errno) (posn errno)
(unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr) (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
(declare (type (or index null) posn)) (declare (type (or (integer 0) null) posn))
(cond ((fixnump posn) (cond (posn
;; Adjust for buffered output: ;; Adjust for buffered output:
;; If there is any output buffered, the *real* file position ;; If there is any output buffered, the *real* file position
;; will be larger than reported by lseek because lseek ;; will be larger than reported by lseek because lseek
...@@ -1081,8 +1080,9 @@ ...@@ -1081,8 +1080,9 @@
(error "Error lseek'ing ~S: ~A" (error "Error lseek'ing ~S: ~A"
stream stream
(unix:get-unix-error-msg errno))))))) (unix:get-unix-error-msg errno)))))))
(let ((offset 0) origin) (let ((offset 0)
(declare (type index offset)) origin)
(declare (type (integer 0) offset))
;; Make sure we don't have any output pending, because if we move the ;; Make sure we don't have any output pending, because if we move the
;; file pointer before writing this stuff, it will be written in the ;; file pointer before writing this stuff, it will be written in the
;; wrong location. ;; wrong location.
...@@ -1095,14 +1095,16 @@ ...@@ -1095,14 +1095,16 @@
(setf (fd-stream-unread stream) nil) (setf (fd-stream-unread stream) nil)
(setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) 0) (setf (fd-stream-ibuf-tail stream) 0)
;; Trash cashed value for listen, so that we check next time. ;; Trash cached value for listen, so that we check next time.
(setf (fd-stream-listen stream) nil) (setf (fd-stream-listen stream) nil)
;; Now move it. ;; Now move it.
(cond ((eq newpos :start) (cond ((eq newpos :start)
(setf offset 0 origin unix:l_set)) (setf offset 0
origin unix:l_set))
((eq newpos :end) ((eq newpos :end)
(setf offset 0 origin unix:l_xtnd)) (setf offset 0
((typep newpos 'index) origin unix:l_xtnd))
((typep newpos '(integer 0))
(setf offset (* newpos (fd-stream-element-size stream)) (setf offset (* newpos (fd-stream-element-size stream))
origin unix:l_set)) origin unix:l_set))
(t (t
...@@ -1110,7 +1112,7 @@ ...@@ -1110,7 +1112,7 @@
(multiple-value-bind (multiple-value-bind
(posn errno) (posn errno)
(unix:unix-lseek (fd-stream-fd stream) offset origin) (unix:unix-lseek (fd-stream-fd stream) offset origin)
(cond ((typep posn 'fixnum) (cond (posn
t) t)
((eq errno unix:espipe) ((eq errno unix:espipe)
nil) nil)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment