From f797da47f8a302ee80772c11f701c1abf45e9467 Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Sat, 20 Mar 2010 15:10:11 -0400 Subject: [PATCH] Implementation for the R6RS (rnrs hashtables) library; Implementation and test cases for the R6RS (rnrs record syntactic) library. * module/Makefile.am: Add rnrs/6/hashtables.scm to RNRS_SOURCES. * module/rnrs/6/hashtables.scm: New file. * module/rnrs/records/6/inspection.scm: (record-type-generative?) Record types are generative iff they have no uid, not vice-versa. * module/rnrs/records/6/syntactic.scm: Finish `define-record-type' implementation; add `record-type-descriptor' and `record-constructor-descriptor' forms. * test-suite/Makefile.am: Add tests/r6rs-records-syntactic.test to SCM_TESTS. * test-suite/tests/r6rs-records-inspection.test: Update tests for `record-type-generative?' to reflect corrected behavior. * test-suite/tests/r6rs-records-syntactic.test: New file. --- module/Makefile.am | 1 + module/rnrs/6/hashtables.scm | 159 ++++++++++++ module/rnrs/records/6/inspection.scm | 2 +- module/rnrs/records/6/syntactic.scm | 235 +++++++++++------- test-suite/Makefile.am | 1 + test-suite/tests/r6rs-records-inspection.test | 8 +- test-suite/tests/r6rs-records-syntactic.test | 116 +++++++++ 7 files changed, 426 insertions(+), 96 deletions(-) create mode 100644 module/rnrs/6/hashtables.scm create mode 100644 test-suite/tests/r6rs-records-syntactic.test diff --git a/module/Makefile.am b/module/Makefile.am index 8e52a3d4b..dac7817a2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -260,6 +260,7 @@ RNRS_SOURCES = \ rnrs/6/conditions.scm \ rnrs/6/control.scm \ rnrs/6/exceptions.scm \ + rnrs/6/hashtables.scm \ rnrs/6/lists.scm \ rnrs/6/syntax-case.scm \ rnrs/arithmetic/6/bitwise.scm \ diff --git a/module/rnrs/6/hashtables.scm b/module/rnrs/6/hashtables.scm new file mode 100644 index 000000000..a31497282 --- /dev/null +++ b/module/rnrs/6/hashtables.scm @@ -0,0 +1,159 @@ +;;; hashtables.scm --- The R6RS hashtables library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs hashtables (6)) + (export make-eq-hashtable + make-eqv-hashtable + make-hashtable + + hashtable? + hashtable-size + hashtable-ref + hashtable-set! + hashtable-delete! + hashtable-contains? + hashtable-update! + hashtable-copy + hashtable-clear! + hashtable-keys + hashtable-entries + + hashtable-equivalence-function + hashtable-hash-function + hashtable-mutable? + + equal-hash + string-hash + string-ci-hash + symbol-hash) + (import (rename (only (guile) string-hash-ci string-hash hashq) + (string-hash-ci string-ci-hash)) + (only (ice-9 optargs) define*) + (rename (only (srfi :69) make-hash-table + hash + hash-by-identity + hash-table-size + hash-table-ref/default + hash-table-set! + hash-table-delete! + hash-table-exists + hash-table-update!/default + hash-table-copy + hash-table-equivalence-function + hash-table-hash-function + hash-table-keys + hash-table-fold) + (hash equal-hash) + (hash-by-identity symbol-hash)) + (rnrs base (6)) + (rnrs records procedural (6))) + + (define r6rs:hashtable + (make-record-type-descriptor + 'r6rs:hashtable #f #f #t #t + '#((mutable wrapped-table) (immutable mutable)))) + + (define hashtable? (record-predicate r6rs:hashtable)) + (define make-r6rs-hashtable + (record-constructor (make-record-constructor-descriptor + r6rs:hashtable #f #f))) + (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0)) + (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0)) + (define hashtable-mutable? (record-accessor r6rs:hashtable 1)) + + (define* (make-eq-hashtable #:optional k) + (make-r6rs-hashtable + (if k (make-hash-table eq? hashq k) (make-hash-table eq? hashq)) + #t)) + + (define* (make-eqv-hashtable #:optional k) + (make-r6rs-hashtable + (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hashv)) + #t)) + + (define* (make-hashtable hash-function equiv #:optional k) + (make-r6rs-hashtable + (if k + (make-hash-table equiv hash-function k) + (make-hash-table equiv hash-function)) + #t)) + + (define (hashtable-size hashtable) + (hash-table-size (r6rs:hashtable-wrapped-table hashtable))) + + (define (hashtable-ref hashtable key default) + (hash-table-ref/default + (r6rs:hashtable-wrapped-table hashtable) key default)) + + (define (hashtable-set! hashtable key obj) + (if (hashtable-mutable? hashtable) + (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)) + *unspecified*) + + (define (hashtable-delete! hashtable key) + (if (hashtable-mutable? hashtable) + (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key)) + *unspecified*) + + (define (hashtable-contains? hashtable key) + (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key)) + + (define (hashtable-update! hashtable key proc default) + (if (hashtable-mutable? hashtable) + (hash-table-update!/default + (r6rs:hashtable-wrapped-table hashtable) key proc default)) + *unspecified*) + + (define* (hashtable-copy hashtable #:optional mutable) + (make-r6rs-hashtable + (hash-table-copy (r6rs:hashtable-wrapped-table hashtable)) + (and mutable #t))) + + (define* (hashtable-clear! hashtable #:optional k) + (if (hashtable-mutable? hashtable) + (let* ((ht (r6rs:hashtable-wrapped-table hashtable)) + (equiv (hash-table-equivalence-function ht)) + (hash-function (hash-table-hash-function ht))) + (r6rs:hashtable-set-wrapped-table! + (if k + (make-hash-table equiv hash-function k) + (make-hash-table equiv hash-function))))) + *unspecified*) + + (define (hashtable-keys hashtable) + (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable)))) + + (define (hashtable-entries hashtable) + (let* ((ht (r6rs:hashtable-wrapped-table hashtable)) + (size (hash-table-size ht)) + (keys (make-vector size)) + (vals (make-vector size))) + (hash-table-fold (r6rs:hashtable-wrapped-table hashtable) + (lambda (k v i) + (vector-set! keys i k) + (vector-set! vals i v) + (+ i 1)) + 0) + (values keys vals))) + + (define (hashtable-equivalence-function hashtable) + (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable))) + + (define (hashtable-hash-function hashtable) + (hash-table-hash-function (r6rs:hashtable-wrapped-table hashtable)))) diff --git a/module/rnrs/records/6/inspection.scm b/module/rnrs/records/6/inspection.scm index ee9f1f097..47b289c6e 100644 --- a/module/rnrs/records/6/inspection.scm +++ b/module/rnrs/records/6/inspection.scm @@ -67,7 +67,7 @@ (ensure-rtd rtd) (struct-ref rtd rtd-index-parent)) (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid)) (define (record-type-generative? rtd) - (ensure-rtd rtd) (and (record-type-uid rtd) #t)) + (ensure-rtd rtd) (not (record-type-uid rtd))) (define (record-type-sealed? rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?)) (define (record-type-opaque? rtd) diff --git a/module/rnrs/records/6/syntactic.scm b/module/rnrs/records/6/syntactic.scm index 838f56ac0..d46efbc29 100644 --- a/module/rnrs/records/6/syntactic.scm +++ b/module/rnrs/records/6/syntactic.scm @@ -18,20 +18,34 @@ (library (rnrs records syntactic (6)) - (export define-record-type) - (import (only (guile) *unspecified* unspecified? @ @@) + (export define-record-type + record-type-descriptor + record-constructor-descriptor) + (import (only (guile) *unspecified* and=> gensym unspecified?) (rnrs base (6)) + (rnrs conditions (6)) + (rnrs exceptions (6)) + (rnrs hashtables (6)) (rnrs lists (6)) (rnrs records procedural (6)) (rnrs syntax-case (6)) (only (srfi :1) take)) + (define record-type-registry (make-eq-hashtable)) + + (define (guess-constructor-name record-name) + (string->symbol (string-append "make-" (symbol->string record-name)))) + (define (guess-predicate-name record-name) + (string->symbol (string-append (symbol->string record-name) "?"))) + (define (register-record-type name rtd rcd) + (hashtable-set! record-type-registry name (cons rtd rcd))) + (define (lookup-record-type-descriptor name) + (and=> (hashtable-ref record-type-registry name #f) car)) + (define (lookup-record-constructor-descriptor name) + (and=> (hashtable-ref record-type-registry name #f) cdr)) + (define-syntax define-record-type (lambda (stx) - (define (guess-constructor-name record-name) - (string->symbol (string-append "make-" (symbol->string record-name)))) - (define (guess-predicate-name record-name) - (string->symbol (string-append (symbol->string record-name) "?"))) (syntax-case stx () ((_ (record-name constructor-name predicate-name) record-clause ...) #'(define-record-type0 @@ -49,49 +63,49 @@ (record-name #,constructor-name #,predicate-name) record-clause ...)))))) + (define (sequence n) + (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1))))) + (reverse (seq-inner n))) + (define (number-fields fields) + (define (number-fields-inner fields counter) + (if (null? fields) + '() + (cons (cons fields counter) + (number-fields-inner (cdr fields) (+ counter 1))))) + (number-fields-inner fields 0)) + + (define (process-fields record-name fields) + (define record-name-str (symbol->string record-name)) + (define (guess-accessor-name field-name) + (string->symbol (string-append + record-name-str "-" (symbol->string field-name)))) + (define (guess-mutator-name field-name) + (string->symbol + (string-append + record-name-str "-" (symbol->string field-name) "-set!"))) + + (define (f x) + (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f)) + ((not (list? x)) (error)) + ((eq? (car x) 'immutable) + (cons 'immutable + (case (length x) + ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f)) + ((3) (list (cadr x) (caddr x) #f)) + (else (error))))) + ((eq? (car x) 'mutable) + (cons 'mutable + (case (length x) + ((2) (list (cadr x) + (guess-accessor-name (cadr x)) + (guess-mutator-name (cadr x)))) + ((4) (cdr x)) + (else (error))))) + (else (error)))) + (map f fields)) + (define-syntax define-record-type0 - (lambda (stx) - (define (sequence n) - (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1))))) - (reverse (seq-inner n))) - (define (number-fields fields) - (define (number-fields-inner fields counter) - (if (null? fields) - '() - (cons (cons fields counter) - (number-fields-inner (cdr fields) (+ counter 1))))) - (number-fields-inner fields 0)) - - (define (process-fields record-name fields) - (define record-name-str (symbol->string record-name)) - (define (guess-accessor-name field-name) - (string->symbol (string-append - record-name-str "-" (symbol->string field-name)))) - (define (guess-mutator-name field-name) - (string->symbol - (string-append - record-name-str "-" (symbol->string field-name) "-set!"))) - - (define (f x) - (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f)) - ((not (list? x)) (error)) - ((eq? (car x) 'immutable) - (cons 'immutable - (case (length x) - ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f)) - ((3) (list (cadr x) (caddr x) #f)) - (else (error))))) - ((eq? (car x) 'mutable) - (cons 'mutable - (case (length x) - ((2) (list (cadr x) - (guess-accessor-name (cadr x)) - (guess-mutator-name (cadr x)))) - ((4) (cdr x)) - (else (error))))) - (else (error)))) - (map f fields)) - + (lambda (stx) (syntax-case stx () ((_ (record-name constructor-name predicate-name) record-clause ...) (let loop ((fields *unspecified*) @@ -104,12 +118,12 @@ (parent-rtd *unspecified*) (record-clauses (syntax->datum #'(record-clause ...)))) (if (null? record-clauses) - (let - ((field-names + (let* + ((fields (if (unspecified? fields) '() fields)) + (field-names (datum->syntax #'record-name - (if (unspecified? fields) '() - (list->vector (map (lambda (x) (take x 2)) fields))))) + (list->vector (map (lambda (x) (take x 2)) fields)))) (field-accessors (fold-left (lambda (x c lst) (cons #`(define #,(datum->syntax @@ -126,8 +140,20 @@ lst) lst)) '() fields (sequence (length fields)))) - (parent (datum->syntax - #'record-name (if (unspecified? parent) #f parent))) + + (parent-cd + (datum->syntax + stx (cond ((not (unspecified? parent)) + `(record-constructor-descriptor ,parent)) + ((not (unspecified? parent-rtd)) (cadr parent-rtd)) + (else #f)))) + (parent-rtd + (datum->syntax + stx (cond ((not (unspecified? parent)) + `(record-type-descriptor ,parent)) + ((not (unspecified? parent-rtd)) (car parent-rtd)) + (else #f)))) + (protocol (datum->syntax #'record-name (if (unspecified? protocol) #f protocol))) @@ -136,24 +162,25 @@ #f nongenerative))) (sealed? (if (unspecified? sealed) #f sealed)) (opaque? (if (unspecified? opaque) #f opaque)) - (parent-cd (datum->syntax - #'record-name (if (unspecified? parent-rtd) - #f (caddr parent-rtd)))) - (parent-rtd (datum->syntax - #'record-name (if (unspecified? parent-rtd) - #f (cadr parent-rtd))))) + + (record-name-sym (datum->syntax + stx (list 'quote + (syntax->datum #'record-name))))) #`(begin (define record-name (make-record-type-descriptor - #,(datum->syntax - stx (list 'quote (syntax->datum #'record-name))) - #,parent #,uid #,sealed? #,opaque? + #,record-name-sym + #,parent-rtd #,uid #,sealed? #,opaque? #,field-names)) (define constructor-name (record-constructor (make-record-constructor-descriptor record-name #,parent-cd #,protocol))) + (register-record-type + #,record-name-sym + record-name (make-record-constructor-descriptor + record-name #,parent-cd #,protocol)) (define predicate-name (record-predicate record-name)) #,@field-accessors #,@field-mutators)) @@ -165,36 +192,62 @@ (cdr cr)) parent protocol sealed opaque nongenerative constructor parent-rtd (cdr record-clauses)) - (error))) - ((parent) (if (unspecified? parent) - (loop fields (cadr cr) protocol sealed opaque - nongenerative constructor parent-rtd - (cdr record-clauses)) - (error))) - ((protocol) (if (unspecified? protocol) - (loop fields parent (cadr cr) sealed opaque - nongenerative constructor parent-rtd - (cdr record-clauses)) - (error))) - ((sealed) (if (unspecified? sealed) - (loop fields parent protocol (cadr cr) opaque - nongenerative constructor parent-rtd - (cdr record-clauses)) - (error))) + (raise (make-assertion-violation)))) + ((parent) + (if (not (unspecified? parent-rtd)) + (raise (make-assertion-violation))) + (if (unspecified? parent) + (loop fields (cadr cr) protocol sealed opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (raise (make-assertion-violation)))) + ((protocol) + (if (unspecified? protocol) + (loop fields parent (cadr cr) sealed opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (raise (make-assertion-violation)))) + ((sealed) + (if (unspecified? sealed) + (loop fields parent protocol (cadr cr) opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (raise (make-assertion-violation)))) ((opaque) (if (unspecified? opaque) (loop fields parent protocol sealed (cadr cr) nongenerative constructor parent-rtd (cdr record-clauses)) - (error))) - ((nongenerative) (if (unspecified? nongenerative) - (loop fields parent protocol sealed - opaque (cadr cr) constructor - parent-rtd (cdr record-clauses)) - (error))) - ((parent-rtd) (if (unspecified? parent-rtd) - (loop fields parent protocol sealed opaque - nongenerative constructor parent-rtd - (cdr record-clauses)) - (error))) - (else (error)))))))))) + (raise (make-assertion-violation)))) + ((nongenerative) + (if (unspecified? nongenerative) + (let ((uid (list 'quote + (or (and (> (length cr) 1) (cadr cr)) + (gensym))))) + (loop fields parent protocol sealed + opaque uid constructor + parent-rtd (cdr record-clauses))) + (raise (make-assertion-violation)))) + ((parent-rtd) + (if (not (unspecified? parent)) + (raise (make-assertion-violation))) + (if (unspecified? parent-rtd) + (loop fields parent protocol sealed opaque + nongenerative constructor (cdr cr) + (cdr record-clauses)) + (raise (make-assertion-violation)))) + (else (raise (make-assertion-violation))))))))))) + + (define-syntax record-type-descriptor + (lambda (stx) + (syntax-case stx () + ((_ name) #`(lookup-record-type-descriptor + #,(datum->syntax + stx (list 'quote (syntax->datum #'name)))))))) + + (define-syntax record-constructor-descriptor + (lambda (stx) + (syntax-case stx () + ((_ name) #`(lookup-record-constructor-descriptor + #,(datum->syntax + stx (list 'quote (syntax->datum #'name)))))))) ) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index fa83f9a86..7b5882068 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -81,6 +81,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/r6rs-ports.test \ tests/r6rs-records-inspection.test \ tests/r6rs-records-procedural.test \ + tests/r6rs-records-syntactic.test \ tests/rnrs-libraries.test \ tests/ramap.test \ tests/reader.test \ diff --git a/test-suite/tests/r6rs-records-inspection.test b/test-suite/tests/r6rs-records-inspection.test index 717bb498d..8603626b6 100644 --- a/test-suite/tests/r6rs-records-inspection.test +++ b/test-suite/tests/r6rs-records-inspection.test @@ -86,14 +86,14 @@ (not (record-type-uid rtd))))) (with-test-prefix "record-type-generative?" - (pass-if "#t when uid is not #f" + (pass-if "#f when uid is not #f" (let* ((uid (gensym)) (rtd (make-record-type-descriptor uid #f uid #f #f '#()))) - (record-type-generative? rtd))) + (not (record-type-generative? rtd)))) - (pass-if "#f when uid is #f" + (pass-if "#t when uid is #f" (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) - (not (record-type-generative? rtd))))) + (record-type-generative? rtd)))) (with-test-prefix "record-type-sealed?" (pass-if "#t when sealed? is #t" diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test new file mode 100644 index 000000000..64b2fbb02 --- /dev/null +++ b/test-suite/tests/r6rs-records-syntactic.test @@ -0,0 +1,116 @@ +;;; r6rs-records-syntactic.test --- Test suite for R6RS (rnrs records syntactic) + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(define-module (test-suite test-rnrs-records-syntactic) + :use-module ((rnrs records syntactic) :version (6)) + :use-module ((rnrs records procedural) :version (6)) + :use-module ((rnrs records inspection) :version (6)) + :use-module (test-suite lib)) + +(define-record-type simple-rtd) +(define-record-type + (specified-rtd specified-rtd-constructor specified-rtd-predicate)) +(define-record-type parent-rtd (fields x y)) +(define-record-type child-parent-rtd-rtd + (parent-rtd (record-type-descriptor parent-rtd) + (record-constructor-descriptor parent-rtd)) + (fields z)) +(define-record-type child-parent-rtd (parent parent-rtd) (fields z)) +(define-record-type mutable-fields-rtd + (fields (mutable mutable-bar) + (mutable mutable-baz mutable-baz-accessor mutable-baz-mutator))) +(define-record-type immutable-fields-rtd + (fields immutable-foo + (immutable immutable-bar) + (immutable immutable-baz immutable-baz-accessor))) +(define-record-type protocol-rtd + (fields (immutable x) (immutable y)) + (protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))) +(define-record-type sealed-rtd (sealed #t)) +(define-record-type opaque-rtd (opaque #t)) +(define-record-type nongenerative-rtd (nongenerative)) +(define-record-type nongenerative-uid-rtd (nongenerative foo)) + +(with-test-prefix "simple record names" + (pass-if "define-record-type defines record type" + (defined? 'simple-rtd)) + + (pass-if "define-record-type defines record predicate" + (defined? 'simple-rtd?)) + + (pass-if "define-record-type defines record-constructor" + (defined? 'make-simple-rtd))) + +(with-test-prefix "fully-specified record names" + (pass-if "define-record-type defines named predicate" + (defined? 'specified-rtd-predicate)) + + (pass-if "define-record-type defines named constructor" + (defined? 'specified-rtd-constructor))) + +(pass-if "parent-rtd clause includes specified parent" + (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd)) + +(pass-if "parent clause includes specified parent" + (eq? (record-type-parent child-parent-rtd) parent-rtd)) + +(pass-if "protocol clause includes specified protocol" + (let ((protocol-record (make-protocol-rtd 1 2))) + (and (eqv? (protocol-rtd-x protocol-record) 2) + (eqv? (protocol-rtd-y protocol-record) 3)))) + +(pass-if "sealed clause produces sealed type" + (record-type-sealed? sealed-rtd)) + +(pass-if "opaque clause produces opaque type" + (record-type-opaque? opaque-rtd)) + +(with-test-prefix "nongenerative" + (pass-if "nongenerative clause produces nongenerative type" + (not (record-type-generative? nongenerative-rtd))) + + (pass-if "nongenerative clause preserves specified uid" + (and (not (record-type-generative? nongenerative-uid-rtd)) + (eq? (record-type-uid nongenerative-uid-rtd) 'foo)))) + +(with-test-prefix "fields" + (pass-if "raw symbol produces accessor only" + (and (defined? 'immutable-fields-rtd-immutable-foo) + (not (defined? 'immutable-fields-rtd-immutable-foo-set!)))) + + (pass-if "(immutable x) form produces accessor only" + (and (defined? 'immutable-fields-rtd-immutable-bar) + (not (defined? 'immutable-fields-rtd-immutable-bar-set!)))) + + (pass-if "(immutable x y) form produces named accessor" + (defined? 'immutable-baz-accessor)) + + (pass-if "(mutable x) form produces accessor and mutator" + (and (defined? 'mutable-fields-rtd-mutable-bar) + (defined? 'mutable-fields-rtd-mutable-bar-set!))) + + (pass-if "(mutable x y) form produces named accessor and mutator" + (and (defined? 'mutable-baz-accessor) + (defined? 'mutable-baz-mutator)))) + +(pass-if "record-type-descriptor returns rtd" + (eq? (record-type-descriptor simple-rtd) simple-rtd)) + +(pass-if "record-constructor-descriptor returns rcd" + (procedure? (record-constructor (record-constructor-descriptor simple-rtd))))