mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Julian Graham
parent
00532e348e
commit
f797da47f8
7 changed files with 426 additions and 96 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
159
module/rnrs/6/hashtables.scm
Normal file
159
module/rnrs/6/hashtables.scm
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
116
test-suite/tests/r6rs-records-syntactic.test
Normal file
116
test-suite/tests/r6rs-records-syntactic.test
Normal file
|
|
@ -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))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue