test-suite/tests/srfi-26.test

   1 ; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26
   2 ; =============================================
   3 ;
   4 ; Sebastian.Egner@philips.com, 3-Jun-2002.
   5 ;
   6 ; This file checks a few assertions about the implementation.
   7 ; If you run it and no error message is issued, the implementation
   8 ; is correct on the cases that have been tested.
   9 ;
  10 ; compliance:
  11 ;   Scheme R5RS with
  12 ;     SRFI-23: error
  13 ;
  14 ; loading this file into Scheme 48 0.57 after 'cut.scm' has been loaded:
  15 ;   ,open srfi-23
  16 ;   ,load check.scm
  17
  18 ; (check expr)
  19 ;    evals expr and issues an error if it is not #t.
  20
  21 (define-module (test-srfi-26)
  22   #:use-module (test-suite lib)
  23   #:use-module (srfi srfi-26))
  24
  25 (define (check expr)
  26   (pass-if "cut/cute" (eval expr (interaction-environment))))
  27
  28 ; (check-all)
  29 ;    runs several tests on cut and reports.
  30
  31 (define (check-all)
  32   (for-each
  33    check
  34    '( ; cuts
  35      (equal? ((cut list)) '())
  36      (equal? ((cut list <...>)) '())
  37      (equal? ((cut list 1)) '(1))
  38      (equal? ((cut list <>) 1) '(1))
  39      (equal? ((cut list <...>) 1) '(1))
  40      (equal? ((cut list 1 2)) '(1 2))
  41      (equal? ((cut list 1 <>) 2) '(1 2))
  42      (equal? ((cut list 1 <...>) 2) '(1 2))
  43      (equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4))
  44      (equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4))
  45      (equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
  46      (equal? (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)) '(ok))
  47      (equal?
  48       (let ((a 0))
  49         (map (cut + (begin (set! a (+ a 1)) a) <>)
  50              '(1 2))
  51         a)
  52       2)
  53       ; cutes
  54      (equal? ((cute list)) '())
  55      (equal? ((cute list <...>)) '())
  56      (equal? ((cute list 1)) '(1))
  57      (equal? ((cute list <>) 1) '(1))
  58      (equal? ((cute list <...>) 1) '(1))
  59      (equal? ((cute list 1 2)) '(1 2))
  60      (equal? ((cute list 1 <>) 2) '(1 2))
  61      (equal? ((cute list 1 <...>) 2) '(1 2))
  62      (equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4))
  63      (equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4))
  64      (equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
  65      (equal?
  66       (let ((a 0))
  67         (map (cute + (begin (set! a (+ a 1)) a) <>)
  68              '(1 2))
  69         a)
  70       1))))
  71
  72 ; run the checks when loading
  73 (with-test-prefix "SRFI-26"
  74   (check-all))