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

sb-grovel: don't add trailing zero-length padding

Browse source
This commit is contained in:
Stas Boukarev 2026-04-29 22:50:31 +03:00
parent c3fc019edf
commit 3ae56c4c92
1 changed files with 35 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

71
contrib/sb-grovel/foreign-glue.lisp
View file

@ -339,47 +339,46 @@ deeply nested structures."
(defmacro define-c-struct (name size &rest elements) (defmacro define-c-struct (name size &rest elements)
(multiple-value-bind (struct-elements accessors) (multiple-value-bind (struct-elements accessors)
(let* ((root (make-instance 'struct :name name :children nil :offset 0))) (let ((root (make-instance 'struct :name name :children nil :offset 0)))
(loop for e in (sort (copy-list elements) #'< :key #'fourth) (loop for e in (sort (copy-list elements) #'< :key #'fourth)
do (insert-element root (apply 'mk-val e)) do (insert-element root (apply 'mk-val e)))
finally (return root))
(setf (children root) (setf (children root)
(nconc (children root) (nconc (children root)
(list (let ((pad (- size (size root))))
(mk-padding (max 0 (- size (when (> pad 0)
(size root))) (list
(size root))))) (mk-padding pad (size root)))))))
(generate-struct-definition name root nil)) (generate-struct-definition name root nil))
`(progn `(progn
(sb-alien:define-alien-type ,@(first struct-elements)) (sb-alien:define-alien-type ,@(first struct-elements))
,@accessors ,@accessors
;; This macro's lambda vars are uninterned so that they don't refer to ;; This macro's lambda vars are uninterned so that they don't refer to
;; the SB-GROVEL package, but they don't need to be GENSYMed. ;; the SB-GROVEL package, but they don't need to be GENSYMed.
(defmacro ,(sb-int:symbolicate "WITH-" name) (defmacro ,(sb-int:symbolicate "WITH-" name)
(alien (&rest #1=#:initializers) &body #2=#:body) (alien (&rest #1=#:initializers) &body #2=#:body)
`(sb-alien:with-alien ((,alien ,',name)) `(sb-alien:with-alien ((,alien ,',name))
(alien-funcall (extern-alien "memset" (alien-funcall (extern-alien "memset"
(function void system-area-pointer int sb-kernel::os-vm-size-t)) (function void system-area-pointer int sb-kernel::os-vm-size-t))
(sb-alien:alien-sap ,alien) 0 ,,size) (sb-alien:alien-sap ,alien) 0 ,,size)
(let ((,alien (cast ,alien (* ,',name)))) (let ((,alien (cast ,alien (* ,',name))))
(setf ,@(mapcan (setf ,@(mapcan
;; The symbol CONS is not in the SB-GROVEL package, making it more ;; The symbol CONS is not in the SB-GROVEL package, making it more
;; clear that this expander works fine in the absence of sb-grovel. ;; clear that this expander works fine in the absence of sb-grovel.
(lambda (cons) (lambda (cons)
`((,(sb-int:package-symbolicate ,(package-name (symbol-package name)) `((,(sb-int:package-symbolicate ,(package-name (symbol-package name))
,(concatenate 'string (string name) "-") ,(concatenate 'string (string name) "-")
(car cons)) ,alien) (car cons)) ,alien)
,(cadr cons))) ,(cadr cons)))
#1#)) #1#))
,@#2#))) ,@#2#)))
(defconstant ,(sb-int:symbolicate "SIZE-OF-" name) ,size) ; why does this exist? (defconstant ,(sb-int:symbolicate "SIZE-OF-" name) ,size) ; why does this exist?
(defun ,(sb-int:symbolicate "ALLOCATE-" name) () ; and this? (defun ,(sb-int:symbolicate "ALLOCATE-" name) () ; and this?
(let ((sb-kernel:instance (sb-alien:make-alien ,name))) (let ((sb-kernel:instance (sb-alien:make-alien ,name)))
;; The allocator returns 0-filled aliens. It's unknowable whether anyone cares. ;; The allocator returns 0-filled aliens. It's unknowable whether anyone cares.
(alien-funcall (extern-alien "memset" (alien-funcall (extern-alien "memset"
(function void system-area-pointer int sb-kernel::os-vm-size-t)) (function void system-area-pointer int sb-kernel::os-vm-size-t))
(sb-alien:alien-sap sb-kernel:instance) 0 ,size) (sb-alien:alien-sap sb-kernel:instance) 0 ,size)
sb-kernel:instance))))) sb-kernel:instance)))))
;; FIXME: Nothing in SBCL uses this, but kept it around in case there ;; FIXME: Nothing in SBCL uses this, but kept it around in case there
;; are third-party sb-grovel clients. It should go away eventually, ;; are third-party sb-grovel clients. It should go away eventually,