158 lines
5.1 KiB
Scheme
158 lines
5.1 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 unions)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (srfi srfi-9 gnu)
|
||
#:use-module ((srfi srfi-1) #:select (fold every))
|
||
#:use-module ((rnrs base) #:select (assert))
|
||
#:use-module (system foreign)
|
||
#:use-module (rnrs bytevectors)
|
||
#:export (<union>
|
||
union
|
||
union-ref
|
||
alignof*
|
||
sizeof*
|
||
make-c-struct*
|
||
parse-c-struct*))
|
||
|
||
|
||
(define (tree-map f tree . trees)
|
||
(cond ((null? tree) '())
|
||
((list? (car tree)) (cons (tree-map f (car tree))
|
||
(tree-map f (cdr tree))))
|
||
(else (cons (f (car tree))
|
||
(tree-map f (cdr tree))))))
|
||
|
||
|
||
;;+TODO: memoize alignof and sizeof
|
||
(define-record-type <union>
|
||
(%make-union members)
|
||
union?
|
||
(members %union-members))
|
||
|
||
(set-record-type-printer! <union>
|
||
(lambda (union port)
|
||
(display "(union " port)
|
||
(map (lambda (x)
|
||
(display x port)
|
||
(write-char #\Space port))
|
||
(%union-members union))
|
||
(write-char #\) port)))
|
||
|
||
(define (union . members)
|
||
"Used to build a union type specifier. MEMBERS should be an
|
||
assoc. list, where keys are used to access each union member in
|
||
`union-ref`."
|
||
(assert (every list? members))
|
||
(%make-union members))
|
||
|
||
(define (union-ref union key)
|
||
(or (assq-ref (%union-members union) key)
|
||
(error 'invalid-arg "union-ref" key)))
|
||
|
||
(define (union-members union)
|
||
"Returns a list of all the variants of a union (the MEMBERS
|
||
assoc. list that was given to `union` without its keys)."
|
||
(map cdr (%union-members union)))
|
||
|
||
;; represents a padding (a space) in a C struct
|
||
(define-record-type <pad>
|
||
(pad offset)
|
||
pad?
|
||
(offset pad-offset))
|
||
|
||
(set-record-type-printer! <pad>
|
||
(lambda (pad port)
|
||
(simple-format port "(pad ~a)" (pad-offset pad))))
|
||
|
||
|
||
(define (padding? types)
|
||
"Returns #t if the only primitive types in TYPES are paddings."
|
||
(cond ((null? types) #t)
|
||
((list? (car types)) (and (padding? (car types))
|
||
(padding? (cdr types))))
|
||
(else (and (pad? (car types))
|
||
(padding? (cdr types))))))
|
||
;; (align offset alignment) → smallest multiple of alignment that is
|
||
;; greater than or equal to offset.
|
||
;; alignment must be a power of 2.
|
||
(define align (@@ (system foreign) align))
|
||
|
||
(define (alignof* type)
|
||
"A variant of alignof that accepts unions (and paddings)."
|
||
(define (maxalign l)
|
||
(fold (lambda (x m) (max m (alignof* x))) 1 l))
|
||
(cond ((union? type) (maxalign (union-members type)))
|
||
((pad? type) 1)
|
||
((list? type) (maxalign type))
|
||
(else (alignof type))))
|
||
|
||
;;; note: until Guile 2.1.0, sizeof does not consider structures
|
||
;;; trailing padding (this is corrected in commit
|
||
;;; cff1d39b2003470b5dcdab988e279587ae2eed8c). Therefore, the
|
||
;;; following version of sizeof reimplements the computation of a
|
||
;;; structure’s size.
|
||
|
||
(define (sizeof* type)
|
||
"A variant of sizeof that accepts unions (and paddings)."
|
||
(define (maxsize l)
|
||
(fold (lambda (x m) (max m (sizeof* x))) 0 l))
|
||
(define (sumsize l)
|
||
(fold (lambda (x s) (+ s (sizeof* x))) 0 l))
|
||
(cond ((union? type) (maxsize (union-members type)))
|
||
((pad? type) (pad-offset type))
|
||
((list? type) (let ((struct-alignment (alignof* type)))
|
||
(align
|
||
(fold (lambda (type offset)
|
||
(+ (align offset (alignof* type))
|
||
(sizeof* type)))
|
||
0
|
||
type)
|
||
struct-alignment)))
|
||
(else (sizeof type))))
|
||
|
||
(define (union-ref-padded union key)
|
||
(cond (key
|
||
(let* ((type (union-ref union key))
|
||
(offset (- (sizeof* union) (sizeof* type))))
|
||
(append type (if (> offset 0)
|
||
(list (pad offset))
|
||
'()))))
|
||
(else
|
||
(list (pad (sizeof* union))))))
|
||
|
||
(define (replace-unions types union-refs)
|
||
(let* ((stack (list-copy union-refs)))
|
||
(let lp ((types types))
|
||
(cond ((null? types) '())
|
||
((list? (car types)) (cons (lp (car types))
|
||
(lp (cdr types))))
|
||
((union? (car types))
|
||
(when (null? stack)
|
||
(throw 'invalid-arg "replace-unions" union-refs))
|
||
(let ((key (car stack)))
|
||
(set! stack (cdr stack))
|
||
(cons (lp (union-ref-padded (car types) key))
|
||
(lp (cdr types)))))
|
||
(else (cons (car types)
|
||
(lp (cdr types))))))))
|
||
|
||
;; file separed for copyright reasons
|
||
(include "unions-read-write.scm")
|