From 3fdbadfa8c5fcfa51a1875235b6c50fa093d2051 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 3 Oct 2024 08:54:40 -0400 Subject: First commit! --- tests/test-bstruct.scm | 278 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/utils.scm | 24 +++++ 2 files changed, 302 insertions(+) create mode 100644 tests/test-bstruct.scm create mode 100644 tests/utils.scm (limited to 'tests') diff --git a/tests/test-bstruct.scm b/tests/test-bstruct.scm new file mode 100644 index 0000000..1bd54fb --- /dev/null +++ b/tests/test-bstruct.scm @@ -0,0 +1,278 @@ +;;; guile-bstruct -- Binary structures for Guile +;;; Copyright © 2024 David Thompson +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (tests test-bstruct) + #:use-module (bstruct) + #:use-module (srfi srfi-64) + #:use-module (system foreign) + #:use-module (tests utils)) + +;; For testing basic structs. +(define-bstruct + (struct (x f32) (y f32))) + +(define-bstruct + (struct (xy ) (uv ))) + +;; For testing arrays. +(define-bstruct + (array 16 f32)) + +;; For testing variable length arrays. +(define-bstruct + (struct (items (* f32)))) + +;; For testing unions. +(define-bstruct + (struct (type u8) (x s32) (y s32))) + +(define-bstruct + (struct (type u8) (button u8) (state u8) (x s32) (y s32))) + +(define-bstruct + (union (type u8) + (mouse-move ) + (mouse-button ))) + +;; For testing recursive types. +(define-bstruct + (struct (item int) (next (* )))) + +;; For testing proper sizing. +(define-bstruct + (struct + (a u64) + (b u32) + (c u64) + (d u32))) + +(test-suite "bstruct" + (test-group "bstruct?" + (test-assert (bstruct? (bstruct-alloc ))) + (test-assert (not (bstruct? 'vec2))) + (test-assert (bstruct? (bstruct-alloc ))) + (test-assert (not (bstruct? (bstruct-alloc ))))) + + (test-group "bstruct-=?" + (test-assert (bstruct-=? + (bstruct-alloc (x 42) (y 69)) + (bstruct-alloc (x 42) (y 69)))) + (test-assert (not (bstruct-=? + (bstruct-alloc (x 42) (y 69)) + (bstruct-alloc (x 77) (y 89)))))) + + (test-group "bstruct->sexp" + (test-equal '(struct (x 42.0) (y 69.0)) + (bstruct->sexp (bstruct-alloc (x 42) (y 69)))) + (test-equal '(struct (xy (struct (x 42.0) (y 69.0))) + (uv (struct (x 77.0) (y 89.0)))) + (bstruct->sexp (bstruct-alloc + ((xy x) 42) ((xy y) 69) + ((uv x) 77) ((uv y) 89)))) + (test-equal '(union + (type 1) + (mouse-move (struct + (type 1) + (x 0) + (y 0))) + (mouse-button (struct + (type 1) + (button 0) + (state 0) + (x 0) + (y 0)))) + (bstruct->sexp (bstruct-alloc (type 1)))) + (test-equal '(struct (item 42) (next (* 0))) + (bstruct->sexp (bstruct-alloc (item 42))))) + + (test-group "bstruct->pointer" + (test-equal #vu8(0 0 40 66 0 0 138 66) + (let ((v (bstruct-alloc (x 42) (y 69)))) + (pointer->bytevector (bstruct->pointer v) + (bstruct-sizeof )))) + (let ((bv (f32vector 42 69))) + (test-equal (bytevector->pointer bv 4) + (bstruct->pointer (bstruct-wrap bv 0) y)))) + + (test-group "pointer->bstruct" + (test-equal 69.0 + (let ((v (bstruct-alloc (x 42) (y 69)))) + (bstruct-ref + (pointer->bstruct + (bstruct->pointer v)) + y)))) + + (test-group "bstruct-wrap" + (test-equal 69.0 + (bstruct-ref (bstruct-wrap (f32vector 13 42 69) 4) y))) + + (test-group "bstruct-unwrap" + (test-equal '(#vu8(0 0 40 66 0 0 138 66) 0 1) + (call-with-values + (lambda () + (bstruct-unwrap + (bstruct-alloc (x 42) (y 69)))) + list))) + + (test-group "bstruct-alignof" + (test-equal (alignof (list float float)) + (bstruct-alignof )) + (test-equal (alignof (list (list float float) (list float float))) + (bstruct-alignof )) + (test-equal (alignof (make-list 16 float)) + (bstruct-alignof )) + (test-equal (alignof (list uint8 int32 int32)) + (bstruct-alignof )) + (test-equal (alignof (list uint8 uint8 uint8 int32 int32)) + (bstruct-alignof )) + (test-equal (max (alignof (list uint8)) + (alignof (list uint8 int32 int32)) + (alignof (list uint8 uint8 uint8 int32 int32))) + (bstruct-alignof ))) + + (test-group "bstruct-sizeof" + (test-equal (sizeof (list float float)) + (bstruct-sizeof )) + (test-equal (sizeof (list (list float float) (list float float))) + (bstruct-sizeof )) + (test-equal (sizeof (make-list 16 float)) + (bstruct-sizeof )) + (test-equal (sizeof (list uint8 int32 int32)) + (bstruct-sizeof )) + (test-equal (sizeof (list uint8 uint8 uint8 int32 int32)) + (bstruct-sizeof )) + (test-equal (max (sizeof (list uint8)) + (sizeof (list uint8 int32 int32)) + (sizeof (list uint8 uint8 uint8 int32 int32))) + (bstruct-sizeof )) + (test-equal (sizeof (list uint64 uint32 uint64 uint32)) + (bstruct-sizeof ))) + + (test-group "bstruct-ref" + (test-equal 69.0 + (bstruct-ref (bstruct-alloc (x 42) (y 69)) y)) + (test-equal 42.0 + (bstruct-ref (bstruct-alloc ((uv x) 42)) (uv x))) + (test-equal 4.0 + (let ((bv (f32vector 1 2 3 4))) + (bstruct-ref + (bstruct-alloc + (items (bytevector->pointer bv))) + (items (* 3))))) + (test-equal %null-pointer + (bstruct-ref (bstruct-alloc ) next))) + + (test-group "bstruct-set!" + (test-equal 42.0 + (let ((v (bstruct-alloc ))) + (bstruct-set! v (y 42)) + (bstruct-ref v y))) + (test-equal 42.0 + (let ((a (bstruct-alloc ))) + (bstruct-set! a (7 42)) + (bstruct-ref a 7))) + (test-equal 42.0 + (let* ((bv (f32vector 0 0 0 0)) + (f (bstruct-alloc ))) + (bstruct-set! f (items (bytevector->pointer bv))) + (bstruct-set! f ((items (* 3)) 42)) + (bstruct-ref f (items (* 3))))) + (test-equal 42 + (let ((e (bstruct-alloc ))) + (bstruct-set! e ((mouse-move y) 42)) + (bstruct-ref e (mouse-move y)))) + (test-equal 69 + (let* ((a (bstruct-alloc (item 42))) + (b (bstruct-alloc (item 69)))) + (bstruct-set! a (next (bstruct->pointer b))) + (bstruct-ref a (next * item))))) + + (test-group "bstruct-pack!" + (test-equal (f32vector 42 69) + (let ((bv (f32vector 0 0))) + (bstruct-pack! bv 0 (x 42) (y 69)) + bv)) + (test-equal (f32vector 1 2 3 4) + (let ((bv (f32vector 0 0 0 0))) + (bstruct-pack! bv 0 + (xy (bstruct-alloc (x 1) (y 2))) + ((uv x) 3) + ((uv y) 4)) + bv)) + (test-equal (f32vector 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + 0 0 0 1) + (let ((bv (f32vector 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0))) + (bstruct-pack! bv 0 (0 1) (5 1) (10 1) (15 1)) + bv)) + (test-equal (u8vector 1 2 0 0 3 0 0 0 4 0 0 0) + (let ((bv (make-u8vector (bstruct-sizeof ) 0))) + (bstruct-pack! bv 0 + ((mouse-button type) 1) + ((mouse-button button) 2) + ((mouse-button state) 0) + ((mouse-button x) 3) + ((mouse-button y) 4)) + bv))) + + (test-group "bstruct-unpack" + (test-equal '(42.0 69.0) + (let ((bv (f32vector 42 69))) + (call-with-values (lambda () (bstruct-unpack bv 0 x y)) + list))) + (test-equal (list 1.0 2.0 3.0 4.0) + (let ((bv (f32vector 1 2 3 4))) + (call-with-values (lambda () + (bstruct-unpack bv 0 + (xy x) (xy y) + (uv x) (uv y))) + list))) + (test-equal '(1.0 1.0 1.0 1.0) + (let ((bv (f32vector 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + 0 0 0 1))) + (call-with-values (lambda () + (bstruct-unpack bv 0 0 5 10 15)) + list))) + (test-equal '(1 2 0 3 4) + (let ((bv (u8vector 1 2 0 0 3 0 0 0 4 0 0 0))) + (call-with-values (lambda () + (bstruct-unpack bv 0 + (mouse-button type) + (mouse-button button) + (mouse-button state) + (mouse-button x) + (mouse-button y))) + list)))) + + (test-group "bstruct-copy" + (test-equal '(42.0 69.0) + (let* ((v (bstruct-alloc (x 42) (y 69))) + (v* (bstruct-copy v))) + (list (bstruct-ref v* x) + (bstruct-ref v* y))))) + + (test-group "bstruct-copy!" + (test-equal '(42.0 69.0) + (let* ((v (bstruct-alloc (x 42) (y 69))) + (v* (bstruct-alloc ))) + (bstruct-copy! v v*) + (list (bstruct-ref v* x) + (bstruct-ref v* y)))))) diff --git a/tests/utils.scm b/tests/utils.scm new file mode 100644 index 0000000..1b0d4cd --- /dev/null +++ b/tests/utils.scm @@ -0,0 +1,24 @@ +;;; guile-bstruct -- Binary structures for Guile +;;; Copyright © 2024 David Thompson +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (tests utils) + #:use-module (srfi srfi-64) + #:export (test-suite)) + +(define-syntax-rule (test-suite name body ...) + (begin + (test-begin name) + body ... + (exit (zero? (test-runner-fail-count (test-end)))))) -- cgit v1.2.3