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