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-equal "set-field with unknown first getter"
 122       '(syntax-error set-fields "unknown getter"
 123                      (set-field (blah) s 3)
 124                      blah)
 125     (catch 'syntax-error
 126       (lambda ()
 127         (compile '(let ((s (make-bar (make-foo 5) 2)))
 128                     (set-field (blah) s 3))
 129                  #:env (current-module))
 130         #f)
 131       (lambda (key whom what src form subform)
 132         (list key whom what form subform))))
 133
 134   (pass-if-equal "set-field with unknown second getter"
 135       '(syntax-error set-fields "unknown getter"
 136                      (set-field (bar-j blah) s 3)
 137                      blah)
 138     (catch 'syntax-error
 139       (lambda ()
 140         (compile '(let ((s (make-bar (make-foo 5) 2)))
 141                     (set-field (bar-j blah) s 3))
 142                  #:env (current-module))
 143         #f)
 144       (lambda (key whom what src form subform)
 145         (list key whom what form subform))))
 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-equal "set-fields with unknown first getter"
 171       '(syntax-error set-fields "unknown getter"
 172                      (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 173                      blah)
 174     (catch 'syntax-error
 175       (lambda ()
 176         (compile '(let ((s (make-bar (make-foo 5) 2)))
 177                     (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
 178                  #:env (current-module))
 179         #f)
 180       (lambda (key whom what src form subform)
 181         (list key whom what form subform))))
 182
 183   (pass-if-equal "set-fields with unknown second getter"
 184       '(syntax-error set-fields "unknown getter"
 185                      (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 186                      blah)
 187     (catch 'syntax-error
 188       (lambda ()
 189         (compile '(let ((s (make-bar (make-foo 5) 2)))
 190                     (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
 191                  #:env (current-module))
 192         #f)
 193       (lambda (key whom what src form subform)
 194         (list key whom what form subform))))
 195
 196   (pass-if-equal "set-fields with duplicate field path"
 197       '(syntax-error set-fields "duplicate field path"
 198                      (set-fields s
 199                        ((bar-i foo-x) 1)
 200                        ((bar-i foo-z) 2)
 201                        ((bar-i foo-x) 3))
 202                      (bar-i foo-x))
 203     (catch 'syntax-error
 204       (lambda ()
 205         (compile '(let ((s (make-bar (make-foo 5) 2)))
 206                     (set-fields s
 207                       ((bar-i foo-x) 1)
 208                       ((bar-i foo-z) 2)
 209                       ((bar-i foo-x) 3)))
 210                  #:env (current-module))
 211         #f)
 212       (lambda (key whom what src form subform)
 213         (list key whom what form subform))))
 214
 215   (pass-if-equal "set-fields with one path as a prefix of another"
 216       '(syntax-error set-fields
 217                      "one field path is a prefix of another"
 218                      (set-fields s
 219                        ((bar-i foo-x) 1)
 220                        ((bar-i foo-z) 2)
 221                        ((bar-i) 3))
 222                      (bar-i))
 223     (catch 'syntax-error
 224       (lambda ()
 225         (compile '(let ((s (make-bar (make-foo 5) 2)))
 226                     (set-fields s
 227                       ((bar-i foo-x) 1)
 228                       ((bar-i foo-z) 2)
 229                       ((bar-i) 3)))
 230                  #:env (current-module))
 231         #f)
 232       (lambda (key whom what src form subform)
 233         (list key whom what form subform)))))
 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-equal "set-fields with unknown first getter"
 493         '(syntax-error set-fields "unknown getter"
 494                        (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 495                        blah)
 496       (catch 'syntax-error
 497         (lambda ()
 498           (compile '(let ()
 499                       (define-immutable-record-type foo
 500                         (make-foo x)
 501                         foo?
 502                         (x foo-x)
 503                         (y foo-y set-foo-y)
 504                         (z foo-z set-foo-z))
 505
 506                       (define-immutable-record-type :bar
 507                         (make-bar i j)
 508                         bar?
 509                         (i bar-i)
 510                         (j bar-j set-bar-j))
 511
 512                       (let ((s (make-bar (make-foo 5) 2)))
 513                         (set-fields s ((bar-i foo-x) 1) ((blah) 3))))
 514                    #:env (current-module))
 515           #f)
 516         (lambda (key whom what src form subform)
 517           (list key whom what form subform))))
 518
 519     (pass-if-equal "set-fields with unknown second getter"
 520         '(syntax-error set-fields "unknown getter"
 521                        (set-fields s ((bar-i foo-x) 1) ((blah) 3))
 522                        blah)
 523       (catch 'syntax-error
 524         (lambda ()
 525           (compile '(let ()
 526                       (define-immutable-record-type foo
 527                         (make-foo x)
 528                         foo?
 529                         (x foo-x)
 530                         (y foo-y set-foo-y)
 531                         (z foo-z set-foo-z))
 532
 533                       (define-immutable-record-type :bar
 534                         (make-bar i j)
 535                         bar?
 536                         (i bar-i)
 537                         (j bar-j set-bar-j))
 538
 539                       (let ((s (make-bar (make-foo 5) 2)))
 540                         (set-fields s ((bar-i foo-x) 1) ((blah) 3))))
 541                    #:env (current-module))
 542           #f)
 543         (lambda (key whom what src form subform)
 544           (list key whom what form subform))))
 545
 546     (pass-if-equal "set-fields with duplicate field path"
 547         '(syntax-error set-fields "duplicate field path"
 548                        (set-fields s
 549                          ((bar-i foo-x) 1)
 550                          ((bar-i foo-z) 2)
 551                          ((bar-i foo-x) 3))
 552                        (bar-i foo-x))
 553       (catch 'syntax-error
 554         (lambda ()
 555           (compile '(let ()
 556                       (define-immutable-record-type foo
 557                         (make-foo x)
 558                         foo?
 559                         (x foo-x)
 560                         (y foo-y set-foo-y)
 561                         (z foo-z set-foo-z))
 562
 563                       (define-immutable-record-type :bar
 564                         (make-bar i j)
 565                         bar?
 566                         (i bar-i)
 567                         (j bar-j set-bar-j))
 568
 569                       (let ((s (make-bar (make-foo 5) 2)))
 570                         (set-fields s
 571                           ((bar-i foo-x) 1)
 572                           ((bar-i foo-z) 2)
 573                           ((bar-i foo-x) 3))))
 574                    #:env (current-module))
 575           #f)
 576         (lambda (key whom what src form subform)
 577           (list key whom what form subform))))
 578
 579     (pass-if-equal "set-fields with one path as a prefix of another"
 580         '(syntax-error set-fields
 581                        "one field path is a prefix of another"
 582                        (set-fields s
 583                          ((bar-i foo-x) 1)
 584                          ((bar-i foo-z) 2)
 585                          ((bar-i) 3))
 586                        (bar-i))
 587       (catch 'syntax-error
 588         (lambda ()
 589           (compile '(let ()
 590                       (define-immutable-record-type foo
 591                         (make-foo x)
 592                         foo?
 593                         (x foo-x)
 594                         (y foo-y set-foo-y)
 595                         (z foo-z set-foo-z))
 596
 597                       (define-immutable-record-type :bar
 598                         (make-bar i j)
 599                         bar?
 600                         (i bar-i)
 601                         (j bar-j set-bar-j))
 602
 603                       (let ((s (make-bar (make-foo 5) 2)))
 604                         (set-fields s
 605                           ((bar-i foo-x) 1)
 606                           ((bar-i foo-z) 2)
 607                           ((bar-i) 3))))
 608                    #:env (current-module))
 609           #f)
 610         (lambda (key whom what src form subform)
 611           (list key whom what form subform))))))
 612
 613 \f
 614 (with-test-prefix "record type definition error reporting"
 615
 616   (pass-if-equal "invalid type name"
 617       '(syntax-error define-immutable-record-type
 618                      "expected type name"
 619                      (define-immutable-record-type
 620                        (foobar x y)
 621                        foobar?
 622                        (x foobar-x)
 623                        (y foobar-y))
 624                      (foobar x y))
 625     (catch 'syntax-error
 626       (lambda ()
 627         (compile '(define-immutable-record-type
 628                     (foobar x y)
 629                     foobar?
 630                     (x foobar-x)
 631                     (y foobar-y))
 632                  #:env (current-module))
 633         #f)
 634       (lambda (key whom what src form subform)
 635         (list key whom what form subform))))
 636
 637   (pass-if-equal "invalid constructor spec"
 638       '(syntax-error define-immutable-record-type
 639                      "invalid constructor spec"
 640                      (define-immutable-record-type :foobar
 641                        (make-foobar x y 3)
 642                        foobar?
 643                        (x foobar-x)
 644                        (y foobar-y))
 645                      (make-foobar x y 3))
 646     (catch 'syntax-error
 647       (lambda ()
 648         (compile '(define-immutable-record-type :foobar
 649                     (make-foobar x y 3)
 650                     foobar?
 651                     (x foobar-x)
 652                     (y foobar-y))
 653                  #:env (current-module))
 654         #f)
 655       (lambda (key whom what src form subform)
 656         (list key whom what form subform))))
 657
 658   (pass-if-equal "invalid predicate name"
 659       '(syntax-error define-immutable-record-type
 660                      "expected predicate name"
 661                      (define-immutable-record-type :foobar
 662                        (foobar x y)
 663                        (x foobar-x)
 664                        (y foobar-y))
 665                      (x foobar-x))
 666     (catch 'syntax-error
 667       (lambda ()
 668         (compile '(define-immutable-record-type :foobar
 669                     (foobar x y)
 670                     (x foobar-x)
 671                     (y foobar-y))
 672                  #:env (current-module))
 673         #f)
 674       (lambda (key whom what src form subform)
 675         (list key whom what form subform))))
 676
 677   (pass-if-equal "invalid field spec"
 678       '(syntax-error define-record-type
 679                      "invalid field spec"
 680                      (define-record-type :foobar
 681                        (make-foobar x y)
 682                        foobar?
 683                        (x)
 684                        (y foobar-y))
 685                      (x))
 686     (catch 'syntax-error
 687       (lambda ()
 688         (compile '(define-record-type :foobar
 689                     (make-foobar x y)
 690                     foobar?
 691                     (x)
 692                     (y foobar-y))
 693                  #:env (current-module))
 694         #f)
 695       (lambda (key whom what src form subform)
 696         (list key whom what form subform))))
 697
 698     (pass-if-equal "unknown field in constructor spec"
 699       '(syntax-error define-record-type
 700                      "unknown field in constructor spec"
 701                      (define-record-type :foobar
 702                        (make-foobar x z)
 703                        foobar?
 704                        (x foobar-x)
 705                        (y foobar-y))
 706                      z)
 707     (catch 'syntax-error
 708       (lambda ()
 709         (compile '(define-record-type :foobar
 710                     (make-foobar x z)
 711                     foobar?
 712                     (x foobar-x)
 713                     (y foobar-y))
 714                  #:env (current-module))
 715         #f)
 716       (lambda (key whom what src form subform)
 717         (list key whom what form subform)))))
 718
 719 (with-test-prefix "record compatibility"
 720
 721   (pass-if "record?"
 722     (record? (make-foo 1)))
 723
 724   (pass-if "record-constructor"
 725     (equal? ((record-constructor :foo) 1)
 726             (make-foo 1))))
 727
 728 ;;; Local Variables:
 729 ;;; mode: scheme
 730 ;;; eval: (put 'set-fields 'scheme-indent-function 1)
 731 ;;; End: