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

@@ -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			\

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))))

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) 

module/rnrs/records/6/syntactic.scm

@@ -18,20 +18,34 @@
 
 
 (library (rnrs records syntactic (6))
-  (export define-record-type)
+  (export define-record-type 
-  (import (only (guile) *unspecified* unspecified? @ @@)
+	  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-syntax define-record-type
+  (define record-type-registry (make-eq-hashtable))
-    (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) "?")))
+  (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)
       (syntax-case stx ()
 	((_ (record-name constructor-name predicate-name) record-clause ...)
 	 #'(define-record-type0 
@@ -49,8 +63,6 @@
 	       (record-name #,constructor-name #,predicate-name) 
 	       record-clause ...))))))
 
-  (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)))
@@ -92,6 +104,8 @@
 	    (else (error))))
     (map f fields))
   
+  (define-syntax define-record-type0
+    (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
+	       (let*
-		((field-names
+		((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) 
+		 (record-name-sym (datum->syntax 
-					       #f (caddr parent-rtd))))
+				   stx (list 'quote 
-		 (parent-rtd (datum->syntax 
+					     (syntax->datum #'record-name)))))
-			      #'record-name (if (unspecified? parent-rtd) 
-						#f (cadr parent-rtd)))))
 		  
 		#`(begin 
 		    (define record-name 
 		      (make-record-type-descriptor 
-		       #,(datum->syntax 
+		       #,record-name-sym
-			  stx (list 'quote (syntax->datum #'record-name)))
+		       #,parent-rtd #,uid #,sealed? #,opaque? 
-		       #,parent #,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)))
+			(raise (make-assertion-violation))))
-		   ((parent) (if (unspecified? parent)
+		   ((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))
-				 (error)))
+			(raise (make-assertion-violation))))
-		   ((protocol) (if (unspecified? protocol)
+		   ((protocol) 
+		    (if (unspecified? protocol)
 			(loop fields parent (cadr cr) sealed opaque
 			      nongenerative constructor parent-rtd
 			      (cdr record-clauses))
-				   (error)))
+			(raise (make-assertion-violation))))
-		   ((sealed) (if (unspecified? sealed)
+		   ((sealed) 
+		    (if (unspecified? sealed)
 			(loop fields parent protocol (cadr cr) opaque
 			      nongenerative constructor parent-rtd
 			      (cdr record-clauses))
-				 (error)))
+			(raise (make-assertion-violation))))
 		   ((opaque) (if (unspecified? opaque)
 				 (loop fields parent protocol sealed (cadr cr)
 				       nongenerative constructor parent-rtd
 				       (cdr record-clauses))
-				 (error)))
+				 (raise (make-assertion-violation))))
-		   ((nongenerative) (if (unspecified? nongenerative)
+		   ((nongenerative) 
+		    (if (unspecified? nongenerative)
+			(let ((uid (list 'quote
+					 (or (and (> (length cr) 1) (cadr cr))
+					     (gensym)))))
 			  (loop fields parent protocol sealed
-					      opaque (cadr cr) constructor
+				opaque uid constructor
-					      parent-rtd (cdr record-clauses))
+				parent-rtd (cdr record-clauses)))
-					(error)))
+			(raise (make-assertion-violation))))
-		   ((parent-rtd) (if (unspecified? parent-rtd)
+		   ((parent-rtd) 
+		    (if (not (unspecified? parent))
+			(raise (make-assertion-violation)))
+		    (if (unspecified? parent-rtd)
 			(loop fields parent protocol sealed opaque
-					   nongenerative constructor parent-rtd
+			      nongenerative constructor (cdr cr)
 			      (cdr record-clauses))
-				     (error)))
+			(raise (make-assertion-violation))))
-		   (else (error))))))))))
+		   (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))))))))
 )

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			\

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"

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))))