guile18/test-suite/tests/poe.test

   1 ;;;; poe.test --- exercise ice-9/poe.scm      -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003, 2006 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 2.1 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-ice-9-poe)
  20   #:use-module (test-suite lib)
  21   #:use-module (ice-9 poe))
  22
  23
  24 ;;
  25 ;; pure-funcq
  26 ;;
  27
  28 (with-test-prefix "pure-funcq"
  29
  30   (with-test-prefix "no args"
  31     (define obj (vector 123))  ;; not gc'ed
  32     (define called #f)
  33     (define (foo)
  34       (set! called #t)
  35       obj)
  36
  37     (let ((func (pure-funcq foo)))
  38
  39       (pass-if "called first"
  40         (set! called #f)
  41         (and (eq? obj (func))
  42              called))
  43
  44       (pass-if "not called second"
  45         (set! called #f)
  46         (and (eq? obj (func))
  47              (not called)))))
  48
  49   (with-test-prefix "1 arg"
  50     (define obj1 (vector 123))  ;; not gc'ed
  51     (define obj2 (vector 456))  ;; not gc'ed
  52     (define called #f)
  53     (define (foo sym)
  54       (set! called #t)
  55       (case sym
  56         ((x) obj1)
  57         ((y) obj2)
  58         (else (error "oops"))))
  59
  60     (let ((func (pure-funcq foo)))
  61
  62       (pass-if "called first x"
  63         (set! called #f)
  64         (and (eq? obj1 (func 'x))
  65              called))
  66
  67       (pass-if "not called second x"
  68         (set! called #f)
  69         (and (eq? obj1 (func 'x))
  70              (not called)))
  71
  72       (pass-if "called first y"
  73         (set! called #f)
  74         (and (eq? obj2 (func 'y))
  75              called))
  76
  77       (pass-if "not called second y"
  78         (set! called #f)
  79         (and (eq? obj2 (func 'y))
  80              (not called)))
  81
  82       (pass-if "not called third x"
  83         (set! called #f)
  84         (and (eq? obj1 (func 'x))
  85              (not called))))))
  86
  87 ;;
  88 ;; perfect-funcq
  89 ;;
  90
  91 (with-test-prefix "perfect-funcq"
  92
  93   (with-test-prefix "no args"
  94     (define called #f)
  95     (define (foo)
  96       (set! called #t)
  97       'foo)
  98
  99     (let ((func (perfect-funcq 31 foo)))
 100
 101       (pass-if "called first"
 102         (set! called #f)
 103         (and (eq? 'foo (func))
 104              called))
 105
 106       (pass-if "not called second"
 107         (set! called #f)
 108         (and (eq? 'foo (func))
 109              (not called)))))
 110
 111   (with-test-prefix "1 arg"
 112     (define called #f)
 113     (define (foo str)
 114       (set! called #t)
 115       (string->number str))
 116
 117     (let ((func (perfect-funcq 31 foo)))
 118       (define s1 "123")
 119       (define s2 "123")
 120
 121       (pass-if "called first s1"
 122         (set! called #f)
 123         (and (= 123 (func s1))
 124              called))
 125
 126       (pass-if "not called second s1"
 127         (set! called #f)
 128         (and (= 123 (func s1))
 129              (not called)))
 130
 131       (pass-if "called first s2"
 132         (set! called #f)
 133         (and (= 123 (func s2))
 134              called))
 135
 136       (pass-if "not called second s2"
 137         (set! called #f)
 138         (and (= 123 (func s2))
 139              (not called))))))