101 lines
3.6 KiB
Scheme
101 lines
3.6 KiB
Scheme
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
||
;;;;
|
||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||
;;;;
|
||
;;;; This program is free software: you can redistribute it and/or modify
|
||
;;;; it under the terms of the GNU General Public License as published by
|
||
;;;; the Free Software Foundation, either version 3 of the License, or
|
||
;;;; (at your option) any later version.
|
||
;;;;
|
||
;;;; This program is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;;; GNU General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU General Public License
|
||
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (system foreign-padded)
|
||
#:use-module ((srfi srfi-1) #:select (fold))
|
||
#:use-module (ice-9 match)
|
||
#:use-module (system foreign)
|
||
#:export (union?
|
||
union-size
|
||
union-ref
|
||
alignof*
|
||
sizeof*
|
||
padding
|
||
pad
|
||
make-union))
|
||
|
||
|
||
(define (union? type)
|
||
(match type
|
||
(('union (? integer? size) (? integer? align) (members ...)) #t)
|
||
(_ #f)))
|
||
|
||
(define union-size cadr)
|
||
(define union-align caddr)
|
||
|
||
(define (union-ref key union)
|
||
(match union
|
||
(('union size align (members ...)) (assq-ref members key))
|
||
(_ (scm-error 'wrong-type-arg "union-ref"
|
||
"Wrong type argument in position 2: ~a"
|
||
(list union) (list union)))))
|
||
|
||
(define (alignof* type)
|
||
"A variant of alignof that accepts unions."
|
||
(cond ((union? type) (union-align type))
|
||
((list? type) (fold max 1 (map alignof* type)))
|
||
(else (alignof type))))
|
||
|
||
(define (next-multiple numerator divisor)
|
||
"Raise up NUMERATOR to the most little multiple M of DIVISOR such that
|
||
NUMERATOR <= M."
|
||
(let ((prev-multiple (* divisor (quotient numerator divisor))))
|
||
(if (= prev-multiple numerator)
|
||
numerator
|
||
(+ prev-multiple divisor))))
|
||
|
||
(define (sizeof* type)
|
||
"A variant of sizeof that accepts unions and returns pads the structures in
|
||
relation to their alignment before returning their size."
|
||
(cond ((union? type) (union-size type))
|
||
((list? type) (next-multiple (fold + 0 (map sizeof* type))
|
||
(alignof* type)))
|
||
(#t (sizeof type))))
|
||
|
||
(define* (padding n #:optional (type uint8))
|
||
"Generate a list of N times TYPE."
|
||
(match n
|
||
(0 '())
|
||
(_ (cons type (padding (- n 1))))))
|
||
|
||
(define (pad type size)
|
||
"Pad TYPE upto SIZE."
|
||
(let ((size* (sizeof* type)))
|
||
(cond ((> size* size)
|
||
(scm-error 'wrong-type-arg "pad"
|
||
"Wrong argument in position 2: (sizeof ~a) < ~a"
|
||
(list type size) (list type size)))
|
||
((or (not (list? type)) (union? type))
|
||
(scm-error 'wrong-type-arg "pad"
|
||
"Wrong argument in position 1: ~a"
|
||
(list type) (list type)))
|
||
(else
|
||
(append type (padding (- size size*)))))))
|
||
|
||
(define (make-union . members)
|
||
"Create a union. MEMBERS should be an assoc. list of lists of C types, where
|
||
keys are only used to identify each union member in calls to `union-ref`."
|
||
(let* ((size (fold max 0 (map (compose sizeof* cdr) members)))
|
||
(align (fold max 1 (map (compose alignof* cdr) members)))
|
||
(padded-size (next-multiple size align))
|
||
(padded-members (map (match-lambda
|
||
((key . type) (cons key (pad type
|
||
padded-size))))
|
||
members)))
|
||
(list 'union padded-size align padded-members)))
|
||
|