master: sb-posix: more robust structure round-trips
stassats via Sbcl-commits <[email protected]> Wed, 20 May 2026 17:57:28 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via a72425d87f09bd5bf8af1ba019b676669ac4096a (commit)
from f825ab5db65fd7d68bbd8c39e37a8725409cafce (commit)
- Log -----------------------------------------------------------------
commit a72425d87f09bd5bf8af1ba019b676669ac4096a
Author: Stas Boukarev <[email protected]>
Date: Wed May 20 20:06:58 2026 +0300
sb-posix: more robust structure round-trips
Save and restore any unnamed fields.
---
contrib/sb-posix/constants.lisp | 10 +-----
contrib/sb-posix/defpackage.lisp | 2 --
contrib/sb-posix/interface.lisp | 72 +++++++++++++++++++++++++++++++---------
3 files changed, 58 insertions(+), 26 deletions(-)
diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp
index a78f265bf..14255e9a3 100644
--- a/contrib/sb-posix/constants.lisp
+++ b/contrib/sb-posix/constants.lisp
@@ -433,15 +433,7 @@
(tcflag-t oflag "tcflag_t" "c_oflag")
(tcflag-t cflag "tcflag_t" "c_cflag")
(tcflag-t lflag "tcflag_t" "c_lflag")
- ((array cc-t) cc "cc_t" "c_cc")
- #-sunos
- (speed-t ispeed "speed_t" (:if "defined(__linux__) && !defined(__GLIBC__)"
- "__c_ispeed" ;; musl
- "c_ispeed"))
- #-sunos
- (speed-t ospeed "speed_t" (:if "defined(__linux__) && !defined(__GLIBC__)"
- "__c_ospeed" ;; musl
- "c_ospeed"))))
+ ((array cc-t) cc "cc_t" "c_cc")))
;; utime(), utimes()
#-win32
diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp
index d882e5c44..885f6fc17 100644
--- a/contrib/sb-posix/defpackage.lisp
+++ b/contrib/sb-posix/defpackage.lisp
@@ -21,8 +21,6 @@
#:stat-rdev
#:termios-iflag #:termios-oflag #:termios-cflag
#:termios-lflag #:termios-cc
- #-sunos #:termios-ispeed
- #-sunos #:termios-ospeed
#:timeval-sec #:timeval-usec
#:flock-type #:flock-whence #:flock-start #:flock-len
#:flock-pid
diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index af3e182e9..0e1570164 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -2,18 +2,42 @@
(defmacro define-protocol-class
(name alien-type superclasses slots &rest options)
- (let ((to-protocol (intern (format nil "ALIEN-TO-~A" name)))
- (to-alien (intern (format nil "~A-TO-ALIEN" name))))
+ (let* ((to-protocol (intern (format nil "ALIEN-TO-~A" name)))
+ (to-alien (intern (format nil "~A-TO-ALIEN" name)))
+ (remaining-field-size sb-vm:n-word-bytes)
+ (remaining-fields (loop for field in (sb-alien::alien-record-type-fields
+ (sb-alien-internals:parse-alien-type alien-type nil))
+ for name = (sb-alien-internals:alien-record-field-name field)
+ for offset = (/ (sb-alien-internals:alien-record-field-offset field)
+ 8)
+ for size = (/ (sb-alien-internals:alien-type-bits (sb-alien-internals:alien-record-field-type field))
+ 8)
+ when (eql (search "PADDING-" (string name)) 0)
+ collect (cons offset size)
+ and do (cond ((not (and (zerop (rem offset 4))
+ (zerop (rem size 4))))
+ (setf remaining-field-size 1))
+ ((not (and (zerop (rem offset sb-vm:n-word-bytes))
+ (zerop (rem size sb-vm:n-word-bytes))))
+ (setf remaining-field-size
+ (min remaining-field-size 4))))))
+ (remaining-fields-length (/ (reduce #'+ remaining-fields :key #'cdr)
+ remaining-field-size))
+ (remaining-fields-type `(simple-array (unsigned-byte ,(* remaining-field-size 8))
+ (,remaining-fields-length))))
`(progn
(export ',name :sb-posix)
(defclass ,name ,superclasses
;; KLUDGE: Splice out some slot options (they're
;; for the conversion functions, not for DEFCLASS).
- ,(loop for slotd in slots
- collect
- (let ((slotd (copy-list slotd)))
- (dolist (keyword '(:array-length :from-alien) slotd)
- (remf (cdr slotd) keyword))))
+ (,@(loop for slotd in slots
+ collect
+ (let ((slotd (copy-list slotd)))
+ (dolist (keyword '(:array-length :from-alien) slotd)
+ (remf (cdr slotd) keyword))))
+ ,@(when remaining-fields
+ `((remaining-fields :initform (make-sequence ',remaining-fields-type ,remaining-fields-length
+ :initial-element 0)))))
,@options)
;; TODO (maybe): there's no reason to define to-alien routines
;; struct stat, passwd, or group: OS interfaces only ever write
@@ -50,6 +74,18 @@
(,from-alien (sb-alien:slot alien ',(car slotd))))
`(setf (slot-value instance ',(car slotd))
(sb-alien:slot alien ',(car slotd)))))
+ ,@(when remaining-fields
+ `((let ((vector (the ,remaining-fields-type
+ (slot-value instance 'remaining-fields))))
+ ,@(loop with array-offset = 0
+ for (offset . size) in remaining-fields
+ append (loop repeat (/ size remaining-field-size)
+ for i from (/ offset remaining-field-size)
+ collect `(setf (aref vector ,array-offset)
+ (deref (sb-alien:cast alien (* (unsigned ,(* remaining-field-size 8))))
+ ,i))
+ do
+ (incf array-offset))))))
instance)
(defun ,to-alien (instance &optional alien)
(declare (type (or null (sb-alien:alien (* ,alien-type))) alien)
@@ -70,7 +106,19 @@
;; counterpart of :FROM-ALIEN so far.
else
collect `(setf (sb-alien:slot alien ',(car slotd))
- (slot-value instance ',(car slotd)))))
+ (slot-value instance ',(car slotd))))
+ ,@(when remaining-fields
+ `((let ((vector (the ,remaining-fields-type
+ (slot-value instance 'remaining-fields))))
+ ,@(loop with array-offset = 0
+ for (offset . size) in remaining-fields
+ append (loop repeat (/ size remaining-field-size)
+ for i from (/ offset remaining-field-size)
+ collect `(setf (deref (sb-alien:cast alien (* (unsigned ,(* remaining-field-size 8))))
+ ,i)
+ (aref vector ,array-offset))
+ do
+ (incf array-offset)))))))
(find-class ',name))))
(define-condition sb-posix:syscall-error (error)
@@ -822,13 +870,7 @@ not supported."
(lflag :initarg :lflag :accessor termios-lflag
:documentation "Local modes.")
(cc :initarg :cc :accessor termios-cc :array-length nccs
- :documentation "Control characters.")
- #-sunos
- (ispeed :initarg :ispeed :accessor termios-ispeed
- :documentation "Input speed.")
- #-sunos
- (ospeed :initarg :ospeed :accessor termios-ospeed
- :documentation "Output speed."))
+ :documentation "Control characters."))
(:documentation
"Instances of this class represent I/O characteristics of the terminal."))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL