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.
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 \
--- /dev/null
+;;; 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
+\f
+
+(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))))
(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)
\f
(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
(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*)
(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
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)))
#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))
(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))))))))
)
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 \
(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"
--- /dev/null
+;;; 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
+\f
+
+(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))))
HCoop / bpt / guile.git / commitdiff