guile-srfi-123

run-tests-goops.scm (5466B)

---

 ;;; run-tests-goops.scm --- Part of the guile-srfi-123 generic accessor and modifier operators library.
 
 ;; Copyright © 2025  Yuval Langer <yuval.langer@gmail.com>
 ;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
 
 ;; This program is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU Affero 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 Affero General Public License for more details.
 
 ;; You should have received a copy of the GNU Affero General Public License
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 ;; Permission is hereby granted, free of charge, to any person obtaining
 ;; a copy of this software and associated documentation files (the
 ;; "Software"), to deal in the Software without restriction, including
 ;; without limitation the rights to use, copy, modify, merge, publish,
 ;; distribute, sublicense, and/or sell copies of the Software, and to
 ;; permit persons to whom the Software is furnished to do so, subject to
 ;; the following conditions:
 
 ;; The above copyright notice and this permission notice shall be
 ;; included in all copies or substantial portions of the Software.
 
 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 (use-modules
  ((scheme base) #:select (bytevector))
 
  (rnrs exceptions)
  (rnrs hashtables)
  (rnrs records inspection)
  (rnrs records procedural)
  (rnrs records syntactic)
 
  (srfi srfi-4)
  (srfi srfi-64)
  (srfi srfi-111)
  (srfi srfi-123 goops)
  )
 
 (define using-broken-srfi99 #f)
 
 (define-record-type foo
   (fields
    (mutable a)
    (immutable b))
   )
 
 (define (run-tests)
   (let ((runner (test-runner-create)))
     (parameterize ((test-runner-current runner))
       (test-begin "SRFI-123-GOOPS")
 
       (test-begin "ref")
       (test-assert "bytevector" (= 1 (ref (bytevector 0 1 2) 1)))
       (test-assert "hashtable" (let ((table (make-eqv-hashtable)))
                                  (hashtable-set! table 'foo 0)
                                  (= 0 (ref table 'foo))))
       (test-assert "hashtable default" (let ((table (make-eqv-hashtable)))
                                          (= 1 (ref table 0 1))))
       (test-assert "pair" (= 1 (ref (cons 0 1) 'cdr)))
       (test-assert "list" (= 1 (ref (list 0 1 2) 1)))
       (test-assert "string" (char=? #\b (ref "abc" 1)))
       (test-assert "vector" (= 1 (ref (vector 0 1 2) 1)))
       (test-assert "record" (= 1 (ref (make-foo 0 1) 'b)))
       (values)
       (test-assert "srfi-4" (= 1 (ref (s16vector 0 1 2) 1)))
       (values)
       (test-assert "srfi-111" (= 1 (ref (box 1) '*)))
       (test-end "ref")
 
       (test-assert "ref*" (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr)))
 
       (test-begin "ref setter")
       (test-assert "bytevector" (let ((bv (bytevector 0 1 2)))
                                   (set! (ref bv 1) 3)
                                   (= 3 (ref bv 1))))
       (test-assert "hashtable" (let ((ht (make-eqv-hashtable)))
                                  (set! (ref ht 'foo) 0)
                                  (= 0 (ref ht 'foo))))
       (test-assert "pair" (let ((p (cons 0 1)))
                             (set! (ref p 'cdr) 2)
                             (= 2 (ref p 'cdr))))
       (test-assert "list" (let ((l (list 0 1 2)))
                             (set! (ref l 1) 3)
                             (= 3 (ref l 1))))
       (test-assert "string" (let ((s (string #\a #\b #\c)))
                               (set! (ref s 1) #\d)
                               (char=? #\d (ref s 1))))
       (test-assert "vector" (let ((v (vector 0 1 2)))
                               (set! (ref v 1) 3)
                               (= 3 (ref v 1))))
       (test-assert "record" (let ((r (make-foo 0 1)))
                               (set! (ref r 'a) 2)
                               (= 2 (ref r 'a))))
       (when using-broken-srfi99
         (test-expect-fail 1))
       (test-assert "bad record assignment"
         (not (guard (err (else #f)) (set! (ref (make-foo 0 1) 'b) 2) #t)))
       (values)
       (test-assert "srfi-4" (let ((s16v (s16vector 0 1 2)))
                               (set! (ref s16v 1) 3)
                               (= 3 (ref s16v 1))))
       (values)
       (test-assert "srfi-111" (let ((b (box 0)))
                                 (set! (ref b '*) 1)
                                 (= 1 (ref b '*))))
       (test-end "ref setter")
 
       (test-assert "ref* setter"
         (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_)))
           (set! (ref* obj 1 1 'cdr) 2)
           (= 2 (ref* obj 1 1 'cdr))))
 
       (test-end "SRFI-123-GOOPS")
       (and (= 0 (test-runner-xpass-count runner))
            (= 0 (test-runner-fail-count runner))))))
 
 (if (run-tests)
     (exit 0)
     (exit 1))