Index: /trunk/ccl/level-1/l1-boot-2.lisp =================================================================== --- /trunk/ccl/level-1/l1-boot-2.lisp (revision 4894) +++ /trunk/ccl/level-1/l1-boot-2.lisp (revision 4895) @@ -83,10 +83,10 @@ (def-ccl-pointers fd-streams () (setq *stdin* (make-fd-stream 0 - :private nil + :sharing :lock :direction :input :interactive (not *batch-flag*))) - (setq *stdout* (make-fd-stream 1 :direction :output :private nil)) - - (setq *stderr* (make-fd-stream 2 :direction :output :private nil)) + (setq *stdout* (make-fd-stream 1 :direction :output :sharing :lock)) + + (setq *stderr* (make-fd-stream 2 :direction :output :sharing :lock)) (if *batch-flag* (let* ((tty-fd (let* ((fd (fd-open "/dev/tty" #$O_RDWR))) @@ -98,6 +98,6 @@ :direction :input :interactive t - :private nil) - *terminal-output* (make-fd-stream tty-fd :direction :output :private nil) + :sharing :lock) + *terminal-output* (make-fd-stream tty-fd :direction :output :sharing :lock) *terminal-io* (make-echoing-two-way-stream *terminal-input* *terminal-output*)) Index: /trunk/ccl/level-1/l1-sockets.lisp =================================================================== --- /trunk/ccl/level-1/l1-sockets.lisp (revision 4894) +++ /trunk/ccl/level-1/l1-sockets.lisp (revision 4895) @@ -569,5 +569,5 @@ keepalive reuse-address nodelay broadcast linger local-port local-host backlog class out-of-band-inline - local-filename remote-filename private) + local-filename remote-filename sharing) "Create and return a new socket." (declare (dynamic-extent keys)) @@ -575,5 +575,5 @@ keepalive reuse-address nodelay broadcast linger local-port local-host backlog class out-of-band-inline - local-filename remote-filename private)) + local-filename remote-filename sharing)) (ecase address-family ((:file) (apply #'make-file-socket keys)) @@ -666,5 +666,5 @@ -(defun make-tcp-stream (fd &key format eol (class 'tcp-stream) private &allow-other-keys) +(defun make-tcp-stream (fd &key format eol (class 'tcp-stream) sharing &allow-other-keys) (declare (ignore eol)) ;??? (let ((element-type (ecase format @@ -677,7 +677,7 @@ :direction :io :element-type element-type - :private private))) - -(defun make-file-socket-stream (fd &key format eol (class 'file-socket-stream) private &allow-other-keys) + :sharing sharing))) + +(defun make-file-socket-stream (fd &key format eol (class 'file-socket-stream) sharing &allow-other-keys) (declare (ignore eol)) ;??? (let ((element-type (ecase format @@ -690,5 +690,5 @@ :direction :io :element-type element-type - :private private))) + :sharing sharing))) (defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys) Index: /trunk/ccl/level-1/l1-streams.lisp =================================================================== --- /trunk/ccl/level-1/l1-streams.lisp (revision 4894) +++ /trunk/ccl/level-1/l1-streams.lisp (revision 4895) @@ -275,7 +275,5 @@ (defmethod close ((stream stream) &key abort) (declare (ignore abort)) - (with-slots ((closed closed)) stream - (unless closed - (setf closed t)))) + (open-stream-p stream)) @@ -420,23 +418,39 @@ (defmacro with-ioblock-input-locked ((ioblock) &body body) - `(if (check-ioblock-owner ,ioblock) - (progn ,@body) - (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0))) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-inbuf-lock ,ioblock)))) + (if ,lock + (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0))) (ioblock-inbuf-lock ,ioblock))) - ,@body))) + ,@body) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + (defmacro with-ioblock-output-locked ((ioblock) &body body) - `(if (check-ioblock-owner ,ioblock) - (progn ,@body) - (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0))) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-inbuf-lock ,ioblock)))) + (if ,lock + (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0))) (ioblock-outbuf-lock ,ioblock))) - ,@body))) + ,@body) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) (defmacro with-ioblock-output-locked-maybe ((ioblock) &body body) - `(if (check-ioblock-owner ,ioblock) - (progn ,@body) - (with-ioblock-lock-grabbed-maybe ((locally (declare (optimize (speed 3) (safety 0))) - (ioblock-outbuf-lock ,ioblock))) - ,@body))) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-inbuf-lock ,ioblock)))) + (if ,lock + (with-ioblock-lock-grabbed-maybe ((locally (declare (optimize (speed 3) (safety 0))) + (ioblock-outbuf-lock ,ioblock))) + ,@body) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) (defun %ioblock-advance (ioblock read-p) @@ -484,4 +498,43 @@ (setf (io-buffer-idx buf) (the fixnum (1+ idx))) (schar (io-buffer-buffer buf) idx)))) + +(declaim (inline %private-ioblock-tyi)) +(defun %private-ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (if (ioblock-untyi-char ioblock) + (prog1 (ioblock-untyi-char ioblock) + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %private-ioblock-tyi (if (ioblock-eof ioblock) :eof))) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (schar (io-buffer-buffer buf) idx)))) + +(declaim (inline %locked-ioblock-tyi)) +(defun %locked-ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0))) + (ioblock-inbuf-lock ioblock))) + (if (ioblock-untyi-char ioblock) + (prog1 (ioblock-untyi-char ioblock) + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %locked-ioblock-tyi (if (ioblock-eof ioblock) :eof))) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (schar (io-buffer-buffer buf) idx))))) (declaim (inline %ioblock-tyy-no-hang)) @@ -926,7 +979,14 @@ element-shift interactive - private + (sharing :private) + character-p &allow-other-keys) (declare (ignorable element-shift)) + (when sharing + (unless (or (eq sharing :private) + (eq sharing :lock)) + (if (eq sharing :external) + (setq sharing nil) + (report-bad-arg sharing '(member nil :private :lock :external))))) (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil))) (when ioblock @@ -934,5 +994,5 @@ ioblock)) (stream-create-ioblock stream)))) - (when private + (when (eq sharing :private) (setf (ioblock-owner ioblock) *current-process*)) (when insize @@ -945,6 +1005,12 @@ :size in-size-in-octets :limit insize)) - (unless private + (when (eq sharing :lock) (setf (ioblock-inbuf-lock ioblock) (make-lock))) + (if character-p + (setf (ioblock-read-char-function ioblock) + (case sharing + (:private '%private-ioblock-tyi) + (:lock '%locked-ioblock-tyi) + (t '%ioblock-tyi)))) (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ in-size-in-octets insize) 2)))) ))) @@ -967,5 +1033,5 @@ :limit outsize :size out-size-in-octets)) - (unless private + (when (eq sharing :lock) (setf (ioblock-outbuf-lock ioblock) (make-lock))) (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2)))) @@ -1025,5 +1091,5 @@ (element-type 'character) (class 'fd-stream) - (private t)) + (sharing :private)) (let* ((in-p (member direction '(:io :input))) (out-p (member direction '(:io :output))) @@ -1044,5 +1110,6 @@ (select-stream-force-output-function class)) :close-function 'fd-stream-close - :private private))) + :sharing sharing + :character-p char-p))) ;;; Fundamental streams. @@ -1133,4 +1200,7 @@ fundamental-binary-stream binary-input-stream) + ()) + +(defclass binary-output-stream (output-stream binary-stream) ()) @@ -1633,5 +1703,4 @@ (when (slot-value s 'string) (setf (slot-value s 'string) nil) - (call-next-method) t)) @@ -2543,5 +2612,5 @@ (class *default-file-stream-class*) (elements-per-buffer *elements-per-buffer*) - (private t)) + (sharing :private)) "Return a stream which reads from or writes to FILENAME. Defined keywords: @@ -2563,5 +2632,5 @@ class external-format - private)) + sharing)) (retry-open () :report (lambda (stream) (format stream "Retry opening ~s" filename)) Index: /trunk/ccl/level-1/l1-sysio.lisp =================================================================== --- /trunk/ccl/level-1/l1-sysio.lisp (revision 4894) +++ /trunk/ccl/level-1/l1-sysio.lisp (revision 4895) @@ -509,5 +509,5 @@ class external-format - private) + sharing) (let* ((temp-name nil) @@ -570,5 +570,5 @@ :element-type element-type :elements-per-buffer elements-per-buffer - :private private) + :sharing sharing) (let* ((in-p (member direction '(:io :input))) (out-p (member direction '(:io :output))) @@ -614,5 +614,5 @@ :device fd :external-format real-external-format - :private private)) + :sharing sharing)) (ioblock (stream-ioblock fstream))) (setf (stream-filename fstream) (namestring pathname)