test-suite/tests/srfi-9.test

   1 ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
   2 ;;;; Martin Grabmueller, 2001-05-10
   3 ;;;;
   4 ;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite test-numbers)
  21   #:use-module (test-suite lib)
  22   #:use-module ((system base compile) #:select (compile))
  23   #:use-module (srfi srfi-26)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-9 gnu))
  26
  27
  28 (define-record-type :qux (make-qux) qux?)
  29
  30 (define-record-type :foo (make-foo x) foo?
  31   (x foo-x)
  32   (y foo-y set-foo-y!)
  33   (z foo-z set-foo-z!))
  34
  35 (define-record-type :bar (make-bar i j) bar?
  36   (i bar-i)
  37   (j bar-j set-bar-j!))
  38
  39 (define f (make-foo 1))
  40 (set-foo-y! f 2)
  41
  42 (define b (make-bar 123 456))
  43
  44 (with-test-prefix "constructor"
  45
  46   ;; Constructors are defined using `define-integrable', meaning that direct
  47   ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the
  48   ;; distinction below.
  49
  50   (pass-if-exception "foo 0 args (inline)" exception:syntax-pattern-unmatched
  51      (compile '(make-foo) #:env (current-module)))
  52   (pass-if-exception "foo 2 args (inline)" exception:syntax-pattern-unmatched
  53      (compile '(make-foo 1 2) #:env (current-module)))
  54
  55   (pass-if-exception "foo 0 args" exception:wrong-num-args
  56      (let ((make-foo make-foo))
  57        (make-foo)))
  58   (pass-if-exception "foo 2 args" exception:wrong-num-args
  59      (let ((make-foo make-foo))
  60        (make-foo 1 2))))
  61
  62 (with-test-prefix "predicate"
  63
  64   (pass-if "pass"
  65      (foo? f))
  66   (pass-if "fail wrong record type"
  67      (eq? #f (foo? b)))
  68   (pass-if "fail number"
  69      (eq? #f (foo? 123))))
  70
  71 (with-test-prefix "getter"
  72
  73   (pass-if "foo-x"
  74      (= 1 (foo-x f)))
  75   (pass-if "foo-y"
  76      (= 2 (foo-y f)))
  77
  78   (pass-if-exception "foo-x on number" exception:wrong-type-arg
  79      (foo-x 999))
  80   (pass-if-exception "foo-y on number" exception:wrong-type-arg
  81      (foo-y 999))
  82
  83   ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  84   (pass-if-exception "foo-x on bar" exception:wrong-type-arg
  85      (foo-x b))
  86   (pass-if-exception "foo-y on bar" exception:wrong-type-arg
  87      (foo-y b)))
  88
  89 (with-test-prefix "setter"
  90
  91   (pass-if "set-foo-y!"
  92      (set-foo-y! f #t)
  93      (eq? #t (foo-y f)))
  94
  95   (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg
  96      (set-foo-y! 999 #t))
  97
  98   ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  99   (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg
 100      (set-foo-y! b 99)))
 101
 102 (with-test-prefix "functional setters"
 103
 104   (pass-if "set-field"
 105     (let ((s (make-foo (make-bar 1 2))))
 106       (and (equal? (set-field (foo-x bar-j) s 3)
 107                    (make-foo (make-bar 1 3)))
 108            (equal? (set-field (foo-z) s 'bar)
 109                    (let ((s2 (make-foo (make-bar 1 2))))
 110                      (set-foo-z! s2 'bar)
 111                      s2))
 112            (equal? s (make-foo (make-bar 1 2))))))
 113
 114   (pass-if-exception "set-field on wrong struct type" exception:wrong-type-arg
 115     (let ((s (make-bar (make-foo 5) 2)))
 116       (set-field (foo-x bar-j) s 3)))
 117
 118   (pass-if-exception "set-field on number" exception:wrong-type-arg
 119     (set-field (foo-x bar-j) 4 3))
 120
 121   (pass-if "set-field with unknown first getter"
 122     (catch 'syntax-error
 123       (lambda ()
 124         (compile '(let ((s (make-bar (make-foo 5) 2)))
 125                     (set-field (blah) s 3))
 126                  #:env (current-module))
 127         #f)
 128       (lambda (key whom what src form subform)
 129         (equal? (list key whom what form subform)
 130                 '(syntax-error set-fields "unknown getter"
 131                                (set-field (blah) s 3)
 132                                blah)))))
 133
 134   (pass-if "set-field with unknown second getter"
 135     (catch 'syntax-error
 136       (lambda ()
 137         (compile '(let ((s (make-bar (make-foo 5) 2)))
 138                     (set-field (bar-j blah) s 3))
 139                  #:env (current-module))
 140         #f)
 141       (lambda (key whom what src form subform)
 142         (equal? (list key whom what form subform)
 143                 '(syntax-error set-fields "unknown getter"
 144                                (set-field (bar-j blah) s 3)
 145                                blah)))))
 146
 147   (pass-if "set-fields"
 148     (let ((s (make-foo (make-bar 1 2))))
 149       (and (equal? (set-field (foo-x bar-j) s 3)
 150                    (make-foo (make-bar 1 3)))
 151            (equal? (set-fields s
 152                      ((foo-x bar-j) 3)
 153                      ((foo-z) 'bar))
 154                    (let ((s2 (make-foo (make-bar 1 3))))
 155                      (set-foo-z! s2 'bar)
 156                      s2))
 157            (equal? s (make-foo (make-bar 1 2))))))
 158
 159   (pass-if-exception "set-fields on wrong struct type" exception:wrong-type-arg
 160     (let ((s (make-bar (make-foo 5) 2)))
 161       (set-fields 4
 162         ((foo-x bar-j) 3)
 163         ((foo-y) 'bar))))
 164
 165   (pass-if-exception "set-fields on number" exception:wrong-type-arg
 166     (set-fields 4
 167       ((foo-x bar-j) 3)
 168       ((foo-z) 'bar)))
 169
 170   (pass-if "set-fields with unknown first getter"
 171     (catch 'syntax-error
 172       (lambda ()
 173         (compile '(let ((s (make-bar (make-foo 5) 2)))
 174                     (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
 175                  #:env (current-module))
 176         #f)
 177       (lambda (key whom what src form subform)
 178         (equal? (list key whom what form subform)
 179                 '(syntax-error set-fields "unknown getter"
 180                                (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 181                                blah)))))
 182
 183   (pass-if "set-fields with unknown second getter"
 184     (catch 'syntax-error
 185       (lambda ()
 186         (compile '(let ((s (make-bar (make-foo 5) 2)))
 187                     (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
 188                  #:env (current-module))
 189         #f)
 190       (lambda (key whom what src form subform)
 191         (equal? (list key whom what form subform)
 192                 '(syntax-error set-fields "unknown getter"
 193                                (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 194                                blah)))))
 195
 196   (pass-if "set-fields with duplicate field path"
 197     (catch 'syntax-error
 198       (lambda ()
 199         (compile '(let ((s (make-bar (make-foo 5) 2)))
 200                     (set-fields s
 201                       ((bar-i foo-x) 1)
 202                       ((bar-i foo-z) 2)
 203                       ((bar-i foo-x) 3)))
 204                  #:env (current-module))
 205         #f)
 206       (lambda (key whom what src form subform)
 207         (equal? (list key whom what form subform)
 208                 '(syntax-error set-fields "duplicate field path"
 209                                (set-fields s
 210                                  ((bar-i foo-x) 1)
 211                                  ((bar-i foo-z) 2)
 212                                  ((bar-i foo-x) 3))
 213                                (bar-i foo-x))))))
 214
 215   (pass-if "set-fields with one path as a prefix of another"
 216     (catch 'syntax-error
 217       (lambda ()
 218         (compile '(let ((s (make-bar (make-foo 5) 2)))
 219                     (set-fields s
 220                       ((bar-i foo-x) 1)
 221                       ((bar-i foo-z) 2)
 222                       ((bar-i) 3)))
 223                  #:env (current-module))
 224         #f)
 225       (lambda (key whom what src form subform)
 226         (equal? (list key whom what form subform)
 227                 '(syntax-error set-fields
 228                                "one field path is a prefix of another"
 229                                (set-fields s
 230                                  ((bar-i foo-x) 1)
 231                                  ((bar-i foo-z) 2)
 232                                  ((bar-i) 3))
 233                                (bar-i)))))))
 234
 235 (with-test-prefix "side-effecting arguments"
 236
 237   (pass-if "predicate"
 238     (let ((x 0))
 239       (and (foo? (begin (set! x (+ x 1)) f))
 240            (= x 1)))))
 241
 242 (with-test-prefix "non-toplevel"
 243
 244   (define-record-type :frotz (make-frotz a b) frotz?
 245     (a frotz-a) (b frotz-b set-frotz-b!))
 246
 247   (pass-if "construction"
 248     (let ((frotz (make-frotz 1 2)))
 249       (and (= (frotz-a frotz) 1)
 250            (= (frotz-b frotz) 2))))
 251
 252   (with-test-prefix "functional setters"
 253     (let ()
 254       (define-record-type foo (make-foo x) foo?
 255         (x foo-x)
 256         (y foo-y set-foo-y!)
 257         (z foo-z set-foo-z!))
 258
 259       (define-record-type :bar (make-bar i j) bar?
 260         (i bar-i)
 261         (j bar-j set-bar-j!))
 262
 263       (pass-if "set-field"
 264         (let ((s (make-foo (make-bar 1 2))))
 265           (and (equal? (set-field (foo-x bar-j) s 3)
 266                        (make-foo (make-bar 1 3)))
 267                (equal? (set-field (foo-z) s 'bar)
 268                        (let ((s2 (make-foo (make-bar 1 2))))
 269                          (set-foo-z! s2 'bar)
 270                          s2))
 271                (equal? s (make-foo (make-bar 1 2)))))))
 272
 273     (pass-if "set-fields"
 274
 275       (let ((s (make-foo (make-bar 1 2))))
 276         (and (equal? (set-field (foo-x bar-j) s 3)
 277                      (make-foo (make-bar 1 3)))
 278              (equal? (set-fields s
 279                        ((foo-x bar-j) 3)
 280                        ((foo-z) 'bar))
 281                      (let ((s2 (make-foo (make-bar 1 3))))
 282                        (set-foo-z! s2 'bar)
 283                        s2))
 284              (equal? s (make-foo (make-bar 1 2))))))))
 285
 286 \f
 287 (define-immutable-record-type :baz
 288   (make-baz x y z)
 289   baz?
 290   (x baz-x set-baz-x)
 291   (y baz-y set-baz-y)
 292   (z baz-z set-baz-z))
 293
 294 (define-immutable-record-type :address
 295   (make-address street city country)
 296   address?
 297   (street  address-street)
 298   (city    address-city)
 299   (country address-country))
 300
 301 (define-immutable-record-type :person
 302   (make-person age email address)
 303   person?
 304   (age     person-age)
 305   (email   person-email)
 306   (address person-address))
 307
 308 (with-test-prefix "define-immutable-record-type"
 309
 310   (pass-if "get"
 311     (let ((b (make-baz 1 2 3)))
 312       (and (= (baz-x b) 1)
 313            (= (baz-y b) 2)
 314            (= (baz-z b) 3))))
 315
 316   (pass-if "get non-inlined"
 317     (let ((b (make-baz 1 2 3)))
 318       (equal? (map (cute apply <> (list b))
 319                    (list baz-x baz-y baz-z))
 320               '(1 2 3))))
 321
 322   (pass-if "set"
 323     (let* ((b0 (make-baz 1 2 3))
 324            (b1 (set-baz-x b0 11))
 325            (b2 (set-baz-y b1 22))
 326            (b3 (set-baz-z b2 33)))
 327       (and (= (baz-x b0) 1)
 328            (= (baz-x b1) 11) (= (baz-x b2) 11) (= (baz-x b3) 11)
 329            (= (baz-y b0) 2) (= (baz-y b1) 2)
 330            (= (baz-y b2) 22) (= (baz-y b3) 22)
 331            (= (baz-z b0) 3) (= (baz-z b1) 3) (= (baz-z b2) 3)
 332            (= (baz-z b3) 33))))
 333
 334   (pass-if "set non-inlined"
 335     (let ((set (compose (cut set-baz-x <> 1)
 336                         (cut set-baz-y <> 2)
 337                         (cut set-baz-z <> 3))))
 338       (equal? (set (make-baz 0 0 0)) (make-baz 1 2 3))))
 339
 340   (pass-if "set-field"
 341     (let ((p (make-person 30 "foo@example.com"
 342                           (make-address "Foo" "Paris" "France"))))
 343       (and (equal? (set-field (person-address address-street) p "Bar")
 344                    (make-person 30 "foo@example.com"
 345                                 (make-address "Bar" "Paris" "France")))
 346            (equal? (set-field (person-email) p "bar@example.com")
 347                    (make-person 30 "bar@example.com"
 348                                 (make-address "Foo" "Paris" "France")))
 349            (equal? p (make-person 30 "foo@example.com"
 350                                   (make-address "Foo" "Paris" "France"))))))
 351
 352   (pass-if "set-fields"
 353     (let ((p (make-person 30 "foo@example.com"
 354                           (make-address "Foo" "Paris" "France"))))
 355       (and (equal? (set-fields p
 356                      ((person-email) "bar@example.com")
 357                      ((person-address address-country) "Catalonia")
 358                      ((person-address address-city) "Barcelona"))
 359                    (make-person 30 "bar@example.com"
 360                                 (make-address "Foo" "Barcelona" "Catalonia")))
 361            (equal? (set-fields p
 362                      ((person-email) "bar@example.com")
 363                      ((person-age) 20))
 364                    (make-person 20 "bar@example.com"
 365                                 (make-address "Foo" "Paris" "France")))
 366            (equal? p (make-person 30 "foo@example.com"
 367                                   (make-address "Foo" "Paris" "France"))))))
 368
 369   (with-test-prefix "non-toplevel"
 370
 371     (pass-if "get"
 372       (let ()
 373         (define-immutable-record-type bar
 374           (make-bar x y z)
 375           bar?
 376           (x bar-x)
 377           (y bar-y)
 378           (z bar-z set-bar-z))
 379
 380         (let ((b (make-bar 1 2 3)))
 381           (and (= (bar-x b) 1)
 382                (= (bar-y b) 2)
 383                (= (bar-z b) 3)))))
 384
 385     (pass-if "get non-inlined"
 386       (let ()
 387         (define-immutable-record-type bar
 388           (make-bar x y z)
 389           bar?
 390           (x bar-x)
 391           (y bar-y)
 392           (z bar-z set-bar-z))
 393
 394         (let ((b (make-bar 1 2 3)))
 395           (equal? (map (cute apply <> (list b))
 396                        (list bar-x bar-y bar-z))
 397                   '(1 2 3)))))
 398
 399     (pass-if "set"
 400       (let ()
 401         (define-immutable-record-type bar
 402           (make-bar x y z)
 403           bar?
 404           (x bar-x set-bar-x)
 405           (y bar-y set-bar-y)
 406           (z bar-z set-bar-z))
 407
 408         (let* ((b0 (make-bar 1 2 3))
 409                (b1 (set-bar-x b0 11))
 410                (b2 (set-bar-y b1 22))
 411                (b3 (set-bar-z b2 33)))
 412           (and (= (bar-x b0) 1)
 413                (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11)
 414                (= (bar-y b0) 2) (= (bar-y b1) 2)
 415                (= (bar-y b2) 22) (= (bar-y b3) 22)
 416                (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3)
 417                (= (bar-z b3) 33)))))
 418
 419     (pass-if "set non-inlined"
 420       (let ()
 421         (define-immutable-record-type bar
 422           (make-bar x y z)
 423           bar?
 424           (x bar-x set-bar-x)
 425           (y bar-y set-bar-y)
 426           (z bar-z set-bar-z))
 427
 428         (let ((set (compose (cut set-bar-x <> 1)
 429                             (cut set-bar-y <> 2)
 430                             (cut set-bar-z <> 3))))
 431           (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3)))))
 432
 433     (pass-if "set-field"
 434       (let ()
 435         (define-immutable-record-type address
 436           (make-address street city country)
 437           address?
 438           (street  address-street)
 439           (city    address-city)
 440           (country address-country))
 441
 442         (define-immutable-record-type :person
 443           (make-person age email address)
 444           person?
 445           (age     person-age)
 446           (email   person-email)
 447           (address person-address))
 448
 449         (let ((p (make-person 30 "foo@example.com"
 450                               (make-address "Foo" "Paris" "France"))))
 451           (and (equal? (set-field (person-address address-street) p "Bar")
 452                        (make-person 30 "foo@example.com"
 453                                     (make-address "Bar" "Paris" "France")))
 454                (equal? (set-field (person-email) p "bar@example.com")
 455                        (make-person 30 "bar@example.com"
 456                                     (make-address "Foo" "Paris" "France")))
 457                (equal? p (make-person 30 "foo@example.com"
 458                                       (make-address "Foo" "Paris" "France")))))))
 459
 460     (pass-if "set-fields"
 461       (let ()
 462         (define-immutable-record-type address
 463           (make-address street city country)
 464           address?
 465           (street  address-street)
 466           (city    address-city)
 467           (country address-country))
 468
 469         (define-immutable-record-type :person
 470           (make-person age email address)
 471           person?
 472           (age     person-age)
 473           (email   person-email)
 474           (address person-address))
 475
 476         (let ((p (make-person 30 "foo@example.com"
 477                               (make-address "Foo" "Paris" "France"))))
 478           (and (equal? (set-fields p
 479                          ((person-email) "bar@example.com")
 480                          ((person-address address-country) "Catalonia")
 481                          ((person-address address-city) "Barcelona"))
 482                        (make-person 30 "bar@example.com"
 483                                     (make-address "Foo" "Barcelona" "Catalonia")))
 484                (equal? (set-fields p
 485                          ((person-email) "bar@example.com")
 486                          ((person-age) 20))
 487                        (make-person 20 "bar@example.com"
 488                                     (make-address "Foo" "Paris" "France")))
 489                (equal? p (make-person 30 "foo@example.com"
 490                                       (make-address "Foo" "Paris" "France")))))))
 491
 492     (pass-if "set-fields with unknown first getter"
 493       (let ()
 494         (define-immutable-record-type foo (make-foo x) foo?
 495           (x foo-x)
 496           (y foo-y set-foo-y)
 497           (z foo-z set-foo-z))
 498
 499         (define-immutable-record-type :bar (make-bar i j) bar?
 500           (i bar-i)
 501           (j bar-j set-bar-j))
 502
 503         (catch 'syntax-error
 504          (lambda ()
 505            (compile '(let ((s (make-bar (make-foo 5) 2)))
 506                        (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
 507                     #:env (current-module))
 508            #f)
 509          (lambda (key whom what src form subform)
 510            (equal? (list key whom what form subform)
 511                    '(syntax-error set-fields "unknown getter"
 512                                   (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 513                                   blah))))))
 514
 515     (pass-if "set-fields with unknown second getter"
 516       (let ()
 517         (define-immutable-record-type foo (make-foo x) foo?
 518           (x foo-x)
 519           (y foo-y set-foo-y)
 520           (z foo-z set-foo-z))
 521
 522         (define-immutable-record-type :bar (make-bar i j) bar?
 523           (i bar-i)
 524           (j bar-j set-bar-j))
 525
 526         (catch 'syntax-error
 527          (lambda ()
 528            (compile '(let ((s (make-bar (make-foo 5) 2)))
 529                        (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
 530                     #:env (current-module))
 531            #f)
 532          (lambda (key whom what src form subform)
 533            (equal? (list key whom what form subform)
 534                    '(syntax-error set-fields "unknown getter"
 535                                   (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 536                                   blah))))))
 537
 538     (pass-if "set-fields with duplicate field path"
 539       (let ()
 540         (define-immutable-record-type foo (make-foo x) foo?
 541           (x foo-x)
 542           (y foo-y set-foo-y)
 543           (z foo-z set-foo-z))
 544
 545         (define-immutable-record-type :bar (make-bar i j) bar?
 546           (i bar-i)
 547           (j bar-j set-bar-j))
 548
 549         (catch 'syntax-error
 550          (lambda ()
 551            (compile '(let ((s (make-bar (make-foo 5) 2)))
 552                        (set-fields s
 553                          ((bar-i foo-x) 1)
 554                          ((bar-i foo-z) 2)
 555                          ((bar-i foo-x) 3)))
 556                     #:env (current-module))
 557            #f)
 558          (lambda (key whom what src form subform)
 559            (equal? (list key whom what form subform)
 560                    '(syntax-error set-fields "duplicate field path"
 561                                   (set-fields s
 562                                     ((bar-i foo-x) 1)
 563                                     ((bar-i foo-z) 2)
 564                                     ((bar-i foo-x) 3))
 565                                   (bar-i foo-x)))))))
 566
 567     (pass-if "set-fields with one path as a prefix of another"
 568       (let ()
 569         (define-immutable-record-type foo (make-foo x) foo?
 570           (x foo-x)
 571           (y foo-y set-foo-y)
 572           (z foo-z set-foo-z))
 573
 574         (define-immutable-record-type :bar (make-bar i j) bar?
 575           (i bar-i)
 576           (j bar-j set-bar-j))
 577
 578         (catch 'syntax-error
 579          (lambda ()
 580            (compile '(let ((s (make-bar (make-foo 5) 2)))
 581                        (set-fields s
 582                          ((bar-i foo-x) 1)
 583                          ((bar-i foo-z) 2)
 584                          ((bar-i) 3)))
 585                     #:env (current-module))
 586            #f)
 587          (lambda (key whom what src form subform)
 588            (equal? (list key whom what form subform)
 589                    '(syntax-error set-fields
 590                                   "one field path is a prefix of another"
 591                                   (set-fields s
 592                                     ((bar-i foo-x) 1)
 593                                     ((bar-i foo-z) 2)
 594                                     ((bar-i) 3))
 595                                   (bar-i)))))))))
 596
 597 (with-test-prefix "record compatibility"
 598
 599   (pass-if "record?"
 600     (record? (make-foo 1)))
 601
 602   (pass-if "record-constructor"
 603     (equal? ((record-constructor :foo) 1)
 604             (make-foo 1))))
 605
 606 ;;; Local Variables:
 607 ;;; mode: scheme
 608 ;;; eval: (put 'set-fields 'scheme-indent-function 1)
 609 ;;; End: