[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1
|
From: |
Julian Graham |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-80-gc90df2c |
|
Date: |
Sat, 20 Mar 2010 19:14:55 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c90df2cc6c3b7ef04c0628b8a6f34f7595d54cce
The branch, wip-r6rs-libraries has been updated
via c90df2cc6c3b7ef04c0628b8a6f34f7595d54cce (commit)
via 168a45b6e69bcdd6bcce86f951b3480b28aa392e (commit)
via 5b46e9b9ee9eb44f2c07f4a2c09a399da1ab2956 (commit)
from 55d944f9b2583e0f2e54c5fe9bfd34ac94c38e83 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c90df2cc6c3b7ef04c0628b8a6f34f7595d54cce
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 15:14:46 2010 -0400
Add test cases for record constructor protocols and parent protocol
delegation.
* test-suite/tests/r6rs-records-procedural.test ("simple protocol",
"protocol delegates to parent with protocol"): New tests.
commit 168a45b6e69bcdd6bcce86f951b3480b28aa392e
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 15:10:11 2010 -0400
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.
commit 5b46e9b9ee9eb44f2c07f4a2c09a399da1ab2956
Author: Julian Graham <address@hidden>
Date: Sat Mar 20 14:57:49 2010 -0400
(rnrs conditions) should not depend on (rnrs records syntactic).
* module/rnrs/6/conditions.scm: (define-condition-type) Re-implement
`define-condition-type' in terms of (rnrs records procedural).
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 1 +
module/rnrs/6/conditions.scm | 37 +++--
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-procedural.test | 32 ++++-
test-suite/tests/r6rs-records-syntactic.test | 116 ++++++++++++
9 files changed, 483 insertions(+), 108 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 2f56205..e5510a4 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/conditions.scm b/module/rnrs/6/conditions.scm
index b489999..5916f51 100644
--- a/module/rnrs/6/conditions.scm
+++ b/module/rnrs/6/conditions.scm
@@ -84,7 +84,6 @@
undefined-violation?)
(import (rnrs base (6))
(rnrs records procedural (6))
- (rnrs records syntactic (6))
(rnrs syntax-case (6)))
(define &compound-condition (make-record-type-descriptor
@@ -102,17 +101,33 @@
(syntax-case stx ()
((_ condition-type supertype constructor predicate
(field accessor) ...)
- (let
- ((fields (let* ((field-spec-syntax #'((field accessor) ...))
+ (let*
+ ((fields (let* ((field-spec-syntax #'((field accessor) ...))
(field-specs (syntax->datum field-spec-syntax)))
- (datum->syntax stx
- (cons 'fields
- (map (lambda (field-spec)
- (cons 'immutable field-spec))
- field-specs))))))
- #`(define-record-type (condition-type constructor predicate)
- (parent supertype)
- #,fields))))))
+ (list->vector (map (lambda (field-spec)
+ (cons 'immutable field-spec))
+ field-specs))))
+ (fields-syntax (datum->syntax stx fields)))
+ #`(begin
+ (define condition-type
+ (make-record-type-descriptor
+ #,(datum->syntax
+ stx (list 'quote (syntax->datum #'condition-type)))
+ supertype #f #f #f #,fields-syntax))
+ (define constructor
+ (record-constructor
+ (make-record-constructor-descriptor condition-type #f #f)))
+ (define predicate (record-predicate condition-type))
+ #,@(let f ((accessors '())
+ (counter 0))
+ (if (>= counter (vector-length fields))
+ accessors
+ (f (cons #`(define #,(datum->syntax
+ stx (cadr (vector-ref fields
+ counter)))
+ (record-accessor condition-type #,counter))
+ accessors)
+ (+ counter 1))))))))))
(define &condition (@@ (rnrs records procedural) &condition))
(define &condition-constructor-descriptor
diff --git a/module/rnrs/6/hashtables.scm b/module/rnrs/6/hashtables.scm
new file mode 100644
index 0000000..a314972
--- /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 ee9f1f0..47b289c 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 838f56a..d46efbc 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 0e821bf..21aa2ab 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -75,6 +75,7 @@ SCM_TESTS = tests/alist.test \
tests/r6rs-ports.test \
tests/r6rs-records-inspection.test \
tests/r6rs-records-procedural.test \
+ tests/r6rs-records-syntactic.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
diff --git a/test-suite/tests/r6rs-records-inspection.test
b/test-suite/tests/r6rs-records-inspection.test
index 717bb49..8603626 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-procedural.test
b/test-suite/tests/r6rs-records-procedural.test
index a1b5e2f..04b3459 100644
--- a/test-suite/tests/r6rs-records-procedural.test
+++ b/test-suite/tests/r6rs-records-procedural.test
@@ -68,7 +68,7 @@
'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
(:rtd-2 (make-record-type-descriptor
'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
- (eq? :rtd-1 :rtd-2)))
+ (eq? :rtd-1 :rtd-2)))
(pass-if "&assertion raised on conflicting non-generative types"
(let* ((:rtd-1 (make-record-type-descriptor
@@ -112,6 +112,36 @@
'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
(eqv? success 7))))
+(with-test-prefix "make-record-constructor-descriptor"
+ (pass-if "simple protocol"
+ (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
+ (:point-protocol-cd (make-record-constructor-descriptor
+ :point #f :point-protocol))
+ (make-point (record-constructor :point-protocol-cd))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1))
+ (point (make-point 1 2)))
+ (and (eqv? (point-x point) 2)
+ (eqv? (point-y point) 3))))
+
+ (pass-if "protocol delegates to parent with protocol"
+ (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
+ (:point-protocol-cd (make-record-constructor-descriptor
+ :point #f :point-protocol))
+ (:voxel-protocol (lambda (n)
+ (lambda (x y z)
+ (let ((p (n x y))) (p (+ z 100))))))
+ (:voxel-protocol-cd (make-record-constructor-descriptor
+ :voxel :point-protocol-cd :voxel-protocol))
+ (make-voxel (record-constructor :voxel-protocol-cd))
+ (point-x (record-accessor :point 0))
+ (point-y (record-accessor :point 1))
+ (voxel-z (record-accessor :voxel 0))
+ (voxel (make-voxel 1 2 3)))
+ (and (eqv? (point-x voxel) 2)
+ (eqv? (point-y voxel) 3)
+ (eqv? (voxel-z voxel) 103)))))
+
(with-test-prefix "record-type-descriptor?"
(pass-if "simple"
(record-type-descriptor?
diff --git a/test-suite/tests/r6rs-records-syntactic.test
b/test-suite/tests/r6rs-records-syntactic.test
new file mode 100644
index 0000000..64b2fbb
--- /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))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-80-gc90df2c,
Julian Graham <=