181 lines
5.6 KiB
Scheme
181 lines
5.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 (test-system-foreign-unions)
|
|
#:use-module (srfi srfi-64)
|
|
#:use-module (system foreign)
|
|
#:use-module (system foreign unions))
|
|
|
|
(define-syntax-rule (unions-import name ...)
|
|
(begin (define name (@@ (system foreign unions) name)) ...))
|
|
|
|
(unions-import align
|
|
pad
|
|
padding?
|
|
union-ref-padded
|
|
replace-unions)
|
|
|
|
(test-begin "test-system-foreign-unions")
|
|
|
|
;; padding?
|
|
(test-assert (padding? (list (pad 1))))
|
|
(test-assert (padding? (list (pad 1) (list (pad 2)) (pad 3))))
|
|
|
|
;; alignof*
|
|
(test-equal (alignof '*)
|
|
(alignof* (union (list #:foo '*)
|
|
(list #:bar unsigned-int))))
|
|
(test-equal (alignof '*)
|
|
(alignof* (list (union (list #:foo '*)
|
|
(list #:bar unsigned-int)))))
|
|
|
|
;; sizeof* — unions
|
|
(let ((alignment (alignof (list int64 int16))))
|
|
(test-equal (align (+ 8 2) alignment)
|
|
(sizeof* (union (list #:foo int8)
|
|
(list #:bar int64 int16)))))
|
|
(test-equal 0 (sizeof* (union)))
|
|
(test-equal 1 (sizeof* uint8))
|
|
|
|
;; sizeof* — trailing padding
|
|
(let ((%type (list '* unsigned-int)))
|
|
(test-assert (zero? (remainder (sizeof* %type) (alignof* %type)))))
|
|
|
|
;; union-ref-padded
|
|
(let ((simple-case (union (list #:foo uint16)
|
|
(list #:bar uint8)))
|
|
(complex-case (union (list #:foo uint32 uint16)
|
|
(list #:bar uint8))))
|
|
(test-equal (list uint8 (pad 1))
|
|
(union-ref-padded simple-case #:bar))
|
|
;; test for null padding
|
|
(test-equal (list uint16)
|
|
(union-ref-padded simple-case #:foo))
|
|
;; test for structures trailing padding
|
|
(test-equal (list uint8 (pad (+ 3 2 2)))
|
|
(union-ref-padded complex-case #:bar))
|
|
;; test for unused union
|
|
(test-equal (list (pad 2))
|
|
(union-ref-padded simple-case #f)))
|
|
|
|
;; replace-unions
|
|
;;+TODO: replace ad-hoc alignment values with (sizeof* _) and
|
|
;; (alignof*) forms
|
|
(let ((simple-case (list int16
|
|
(union (list #:foo int16 int8)
|
|
(list #:bar int8))
|
|
int16))
|
|
(nested-case (list int16
|
|
(union (list #:foo int32
|
|
(union (list #:alice int16 int16)
|
|
(list #:bob int8))
|
|
int8)
|
|
(list #:bar int8))
|
|
int16)))
|
|
(test-equal (list int16 (list int16 int8) int16)
|
|
(replace-unions simple-case '(#:foo)))
|
|
(test-equal (list int16 (list int8 (pad (+ 1 1 1))) int16)
|
|
(replace-unions simple-case '(#:bar)))
|
|
(test-equal (list int16 (list (pad 4)) int16)
|
|
(replace-unions simple-case (list #f)))
|
|
(test-equal (list int16 (list int32 (list int16 int16) int8) int16)
|
|
(replace-unions nested-case '(#:foo #:alice)))
|
|
(test-equal (list int16 (list int32 (list int8 (pad (+ 1 2))) int8) int16)
|
|
(replace-unions nested-case '(#:foo #:bob)))
|
|
(test-equal (list int16 (list int8 (pad (+ 3 (+ 2 2) 1 3))) int16)
|
|
(replace-unions nested-case '(#:bar)))
|
|
(test-equal (list int16 (list int32 (list (pad (+ 2 2))) int8) int16)
|
|
(replace-unions nested-case '(#:foo #f))))
|
|
|
|
;;+TODO: write-c-struct*
|
|
;;+TODO: read-c-struct*
|
|
|
|
;; make-c-struct*
|
|
;;
|
|
;; simple-case:
|
|
;; struct {
|
|
;; union {
|
|
;; uint32_t bird_of_prey;
|
|
;; uint8_t uss_defiant;
|
|
;; } foo;
|
|
;; uint16 type;
|
|
;; } ship;
|
|
;;
|
|
;; complex-case:
|
|
;; struct {
|
|
;; union {
|
|
;; struct {
|
|
;; uint32_t code;
|
|
;; union {
|
|
;; struct {
|
|
;; uint64_t uhura;
|
|
;; uint32_t kirk;
|
|
;; uint8_t scotty;
|
|
;; } tos;
|
|
;; struct {
|
|
;; uint32_t picard;
|
|
;; uint8_t weasley;
|
|
;; } nextgen;
|
|
;; } crew;
|
|
;; } enterprise;
|
|
;; struct {
|
|
;; uint16_t class;
|
|
;; union {
|
|
;; uint64_t sphere;
|
|
;; uint8_t cube;
|
|
;; } shape;
|
|
;; uint8 queen_is_here;
|
|
;; } borg;
|
|
;; } ship;
|
|
;; uint16 whatizit;
|
|
;; }
|
|
(let ((simple-case (list (union (list #:bird-of-prey uint32)
|
|
(list #:defiant uint8))
|
|
uint16))
|
|
(complex-case (list (union (list #:enterprise
|
|
uint32
|
|
(union (list #:tos uint64 uint32 uint8)
|
|
(list #:nextgen uint32 uint8)))
|
|
(list #:borg
|
|
uint16
|
|
(union (list #:sphere uint64)
|
|
(list #:cube uint8))
|
|
uint8))
|
|
uint16))
|
|
(klingon (list (list 1) 2))
|
|
(defiant (list (list 3) 4))
|
|
(tos (list (list 5 (list 6 7 8)) 9))
|
|
(cube (list (list 10 (list 11) 12) 13)))
|
|
(test-equal klingon
|
|
(parse-c-struct*
|
|
(make-c-struct* simple-case klingon #:bird-of-prey)
|
|
simple-case #:bird-of-prey))
|
|
(test-equal defiant
|
|
(parse-c-struct*
|
|
(make-c-struct* simple-case defiant #:defiant)
|
|
simple-case #:defiant))
|
|
(test-equal tos
|
|
(parse-c-struct*
|
|
(make-c-struct* complex-case tos #:enterprise #:tos)
|
|
complex-case #:enterprise #:tos))
|
|
(test-equal cube
|
|
(parse-c-struct*
|
|
(make-c-struct* complex-case cube #:borg #:cube) ; brr
|
|
complex-case #:borg #:cube)))
|
|
|
|
(test-end)
|