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)
(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)
do (insert-element root (apply 'mk-val e))
finally (return root))
do (insert-element root (apply 'mk-val e)))
(setf (children root)
(nconc (children root)
(list
(mk-padding (max 0 (- size
(size root)))
(size root)))))
(let ((pad (- size (size root))))
(when (> pad 0)
(list
(mk-padding pad (size root)))))))
(generate-struct-definition name root nil))
`(progn
(sb-alien:define-alien-type ,@(first struct-elements))
,@accessors
;; 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.
(defmacro ,(sb-int:symbolicate "WITH-" name)
(alien (&rest #1=#:initializers) &body #2=#:body)
`(sb-alien:with-alien ((,alien ,',name))
(alien-funcall (extern-alien "memset"
(function void system-area-pointer int sb-kernel::os-vm-size-t))
(sb-alien:alien-sap ,alien) 0 ,,size)
(let ((,alien (cast ,alien (* ,',name))))
(setf ,@(mapcan
;; 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.
(lambda (cons)
`((,(sb-int:package-symbolicate ,(package-name (symbol-package name))
,(concatenate 'string (string name) "-")
(car cons)) ,alien)
,(cadr cons)))
#1#))
,@#2#)))
(defconstant ,(sb-int:symbolicate "SIZE-OF-" name) ,size) ; why does this exist?
(defun ,(sb-int:symbolicate "ALLOCATE-" name) () ; and this?
(let ((sb-kernel:instance (sb-alien:make-alien ,name)))
;; The allocator returns 0-filled aliens. It's unknowable whether anyone cares.
(alien-funcall (extern-alien "memset"
(function void system-area-pointer int sb-kernel::os-vm-size-t))
(sb-alien:alien-sap sb-kernel:instance) 0 ,size)
sb-kernel:instance)))))
(sb-alien:define-alien-type ,@(first struct-elements))
,@accessors
;; 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.
(defmacro ,(sb-int:symbolicate "WITH-" name)
(alien (&rest #1=#:initializers) &body #2=#:body)
`(sb-alien:with-alien ((,alien ,',name))
(alien-funcall (extern-alien "memset"
(function void system-area-pointer int sb-kernel::os-vm-size-t))
(sb-alien:alien-sap ,alien) 0 ,,size)
(let ((,alien (cast ,alien (* ,',name))))
(setf ,@(mapcan
;; 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.
(lambda (cons)
`((,(sb-int:package-symbolicate ,(package-name (symbol-package name))
,(concatenate 'string (string name) "-")
(car cons)) ,alien)
,(cadr cons)))
#1#))
,@#2#)))
(defconstant ,(sb-int:symbolicate "SIZE-OF-" name) ,size) ; why does this exist?
(defun ,(sb-int:symbolicate "ALLOCATE-" name) () ; and this?
(let ((sb-kernel:instance (sb-alien:make-alien ,name)))
;; The allocator returns 0-filled aliens. It's unknowable whether anyone cares.
(alien-funcall (extern-alien "memset"
(function void system-area-pointer int sb-kernel::os-vm-size-t))
(sb-alien:alien-sap sb-kernel:instance) 0 ,size)
sb-kernel:instance)))))
;; FIXME: Nothing in SBCL uses this, but kept it around in case there
;; are third-party sb-grovel clients. It should go away eventually,