common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Don't add finalizers to streams opened via with-open-file

Browse source 
They are going to be closed in unwind-protect.

Suggested by John Mallery.
This commit is contained in:
Stas Boukarev 2026-03-11 19:17:40 +03:00
parent edc7d5716c
commit 0df24a96cf
7 changed files with 35 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
contrib/sb-simple-streams/fndb.lisp
View file

@ -78,7 +78,8 @@ TODO (rudi 2003-05-19): make the above work, make (defknown open) use it.
(:mapped (member t nil))
(:input-handle (or null fixnum stream))
(:output-handle (or null fixnum stream))
#+win32 (:overlapped t))
#+win32 (:overlapped t)
(:auto-close t))
(or stream null)
()
;; :derive-type #'result-type-open-class

6
contrib/sb-simple-streams/impl.lisp
View file

@ -605,7 +605,8 @@
if-exists if-does-not-exist
(external-format :default)
class mapped input-handle output-handle
#+win32 (overlapped t))
#+win32 (overlapped t)
(auto-close t))
"Return a stream which reads from or writes to Filename.
Defined keywords:
:direction - one of :input, :output, :io, or :probe
@ -622,7 +623,7 @@
:input-handle - a stream or Unix file descriptor to read from
:output-handle - a stream or Unix file descriptor to write to"
(declare (ignore element-type external-format input-handle output-handle
#+win32 overlapped
#+win32 overlapped auto-close
if-exists if-does-not-exist))
(let ((class (or class 'sb-sys:fd-stream))
(options (copy-list options))
@ -642,6 +643,7 @@
(when (subtypep class 'file-simple-stream)
(when (eq direction :probe)
(setq class 'probe-simple-stream)))
(remf options :auto-close)
(apply #'make-instance class :filename filespec options))
((subtypep class 'sb-gray:fundamental-stream)
(remf options :class)

13
contrib/sb-simple-streams/internal.lisp
View file

@ -626,11 +626,12 @@
(return nil)))))))))
(defun open-fd-stream (pathname &key (class 'sb-sys:fd-stream)
(direction :input)
(element-type 'base-char)
(if-exists nil if-exists-given)
(if-does-not-exist nil if-does-not-exist-given)
(external-format :default))
(direction :input)
(element-type 'base-char)
(if-exists nil if-exists-given)
(if-does-not-exist nil if-does-not-exist-given)
(external-format :default)
(auto-close t))
(declare (type (or pathname string stream) pathname)
(type (member :input :output :io :probe) direction)
(type (member :error :new-version :rename :rename-and-delete
@ -654,7 +655,7 @@
:pathname pathname
:dual-channel-p nil
:input-buffer-p t
:auto-close t
:auto-close auto-close
:external-format external-format))
(:probe
(let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd

28
src/code/fd-stream.lisp
View file

@ -2253,17 +2253,18 @@
"~@<Couldn't remove ~S while closing ~S~:>" file fd-stream)))))))
(t
(finish-fd-stream-output fd-stream)
(let ((orig (fd-stream-original fd-stream)))
(when (and orig (fd-stream-delete-original fd-stream))
(multiple-value-bind (okay err) (sb-unix:unix-unlink orig)
(unless okay
(file-perror
orig err
"~@<Couldn't delete ~S while closing ~S~:>" orig fd-stream)))))
;; In case of no-abort close, don't *really* close the
;; stream until the last moment -- the cleaning up of the
;; original can be done first.
(release-fd-stream-resources fd-stream))))
(unwind-protect
(let ((orig (fd-stream-original fd-stream)))
(when (and orig (fd-stream-delete-original fd-stream))
(multiple-value-bind (okay err) (sb-unix:unix-unlink orig)
(unless okay
(file-perror
orig err
"~@<Couldn't delete ~S while closing ~S~:>" orig fd-stream)))))
;; In case of no-abort close, don't *really* close the
;; stream until the last moment -- the cleaning up of the
;; original can be done first.
(release-fd-stream-resources fd-stream)))))
(:clear-input
(fd-stream-clear-input fd-stream))
(:force-output
@ -2496,7 +2497,7 @@
(name (if file
(format nil "file ~A" file)
(format nil "descriptor ~W" fd)))
auto-close)
auto-close)
(declare (type index fd) (type (or real null) timeout)
(type (member :none :line :full) buffering))
;; OPEN ensures that the external-format argument is OK before
@ -2631,6 +2632,7 @@
(external-format :default)
;; private options - use at your own risk
(class 'fd-stream)
(auto-close t)
#+win32
(overlapped t)
&aux
@ -2802,7 +2804,7 @@
:dual-channel-p nil
:serve-events nil
:input-buffer-p t
:auto-close t))
:auto-close auto-close))
(:probe
(let ((stream
(%make-fd-stream :name namestring

4
src/code/macros.lisp
View file

@ -1426,6 +1426,8 @@ invoked. In that case it will store into PLACE and start over."
;;;; WITH-FOO i/o-related macros
(sb-xc:defmacro with-open-stream ((var stream) &body body)
(when (typep stream '(cons (eql open) (cons t)))
(setf stream `(open ,@(cdr stream) :auto-close nil)))
(multiple-value-bind (forms decls) (parse-body body nil)
`(let ((,var ,stream))
,@decls
@ -1437,7 +1439,7 @@ invoked. In that case it will store into PLACE and start over."
&body body)
(multiple-value-bind (forms decls) (parse-body body nil)
(let ((abortp (gensym)))
`(let ((,stream (open ,filespec ,@options))
`(let ((,stream (open ,filespec ,@options :auto-close nil))
(,abortp t))
,@decls
(unwind-protect

1
src/compiler/fndb.lisp
View file

@ -1912,6 +1912,7 @@
:append :supersede nil))
(:if-does-not-exist (member :error :create nil))
(:external-format external-format-designator)
(:auto-close t)
#+win32 (:overlapped t))
(or stream null))

3
xperfecthash63.lisp-expr
View file

@ -1697,5 +1697,8 @@
(#(28 2A 2C 2E 30 32 34 36)
"((21 FLOATING-POINT-OVERFLOW) (20 DIVISION-BY-ZERO) (22 DIVISION-BY-ZERO 4294966779) (23 FLOATING-POINT-OVERFLOW 4294966263) (24 FLOATING-POINT-UNDERFLOW 4294965231) (25 FLOATING-POINT-INEXACT 4294963167) (26 FLOATING-POINT-INVALID-OPERATION 4294967166) (27 FLOATING-POINT-EXCEPTION))"
"((& (>> val 1) 7))")
(#(1588B4F0 2A4B00C6 2B465CCD 42D83FFB 96A5F5BD B8D32AF5 ECF81B20 FA4BD0D1)
"(:ALLOW-OTHER-KEYS :AUTO-CLOSE :CLASS :EXTERNAL-FORMAT :IF-DOES-NOT-EXIST :IF-EXISTS :ELEMENT-TYPE :DIRECTION)"
"((& (^ val (>> val 9)) 7))")
)
;; EOF