Implementation and test cases for the R6RS (rnrs records procedural) library,

along with its dependencies.

* module/Makefile.am: Add new R6RS libraries below to RNRS_SOURCES.
* module/rnrs/6/conditions.scm, exceptions.scm, syntax-case.scm: New files.
* module/rnrs/io/6/simple.scm: New file.
* module/rnrs/records/6/procedural.scm, syntactic.scm: New files.
* test-suite/Makefile.am: Add tests/r6rs-records-procedural.test to SCM_TESTS.
* test-suite/tests/r6rs-records-procedural.test: New file.

module/Makefile.am

@@ -257,10 +257,16 @@ SRFI_SOURCES = \
 
 RNRS_SOURCES =					\
   rnrs/6/base.scm				\
+  rnrs/6/conditions.scm				\
   rnrs/6/control.scm				\
+  rnrs/6/exceptions.scm				\
+  rnrs/6/syntax-case.scm			\
   rnrs/arithmetic/6/bitwise.scm			\
   rnrs/bytevector.scm				\
-  rnrs/io/ports.scm
+  rnrs/records/6/procedural.scm			\
+  rnrs/records/6/syntactic.scm			\
+  rnrs/io/ports.scm				\
+  rnrs/io.simple.scm
 
 EXTRA_DIST += scripts/ChangeLog-2008
 EXTRA_DIST += scripts/README

module/rnrs/6/conditions.scm

@@ -0,0 +1,201 @@
+;;; conditions.scm --- The R6RS conditions 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 conditions (6))
+  (export &condition
+	  condition
+	  simple-conditions
+	  condition?
+	  condition-predicate
+	  condition-accessor
+	  define-condition-type
+	  
+	  &message
+	  make-message-condition
+	  message-condition?
+	  condition-message
+
+	  &warning
+	  make-warning
+	  warning?
+
+	  &serious
+	  make-serious-condition
+	  serious-condition?
+
+	  &error
+	  make-error
+	  error?
+
+	  &violation
+	  make-violation
+	  violation?
+
+	  &assertion
+	  make-assertion-violation
+	  assertion-violation?
+
+	  &irritants
+	  make-irritants-condition
+	  irritants-condition?
+	  condition-irritants
+
+	  &who
+	  make-who-condition
+	  who-condition?
+	  condition-who
+
+	  &non-continuable
+	  make-non-continuable-violation
+	  non-continuable-violation?
+
+	  &implementation-restriction
+	  make-implementation-restriction
+	  implementation-restriction-violation?
+
+	  &lexical
+	  make-lexical-violation
+	  lexical-violation?
+
+	  &syntax
+	  make-syntax-violation
+	  syntax-violation?
+	  syntax-violation-form
+	  syntax-violation-subform
+
+	  &undefined
+	  make-undefined-violation
+	  undefined-violation?)
+  (import (rnrs base (6))
+	  (rnrs io simple (6))
+	  (rnrs records procedural (6))
+	  (rnrs records syntactic (6))
+	  (rnrs syntax-case (6)))
+	  
+  (define &compound-condition (make-record-type-descriptor 
+			       '&compound-condition #f #f #f #f
+			       '#((immutable components))))
+  (define compound-condition? (record-predicate &compound-condition))
+  
+  (define make-compound-condition 
+    (record-constructor (make-record-constructor-descriptor 
+			 &compound-condition #f #f)))
+  (define compound-condition-components (record-accessor &compound-condition 0))
+
+  (define-syntax define-condition-type
+    (lambda (stx)
+      (syntax-case stx ()
+	((_ condition-type supertype constructor predicate
+	    (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))))))
+		       
+  (define &condition (@@ (rnrs records procedural) &condition))
+  (define &condition-constructor-descriptor
+    (make-record-constructor-descriptor &condition #f #f))
+  (define condition-internal? (record-predicate &condition))
+
+  (define condition
+    (lambda conditions
+      (define (flatten cond)
+	(if (compound-condition? cond)
+	    (fold append '() (map flatten (compound-condition-components cond)))
+	    cond))
+      (or (for-all condition? conditions)
+	  (raise (make-assertion-violation)))
+      (make-compound-condition (flatten conditions))))
+
+  (define (simple-conditions condition) (record-accessor &compound-condition 0))
+  (define (condition? obj) 
+    (or (compound-condition? obj) (condition-internal? obj)))
+  (define (condition-predicate rtd)
+    (let ((rtd-predicate (record-predicate rtd)))
+      (lambda (obj)
+	(cond ((compound-condition? obj) 
+	       (find rtd-predicate (compound-condition-components obj)))
+	      ((condition-internal? obj) (rtd-predicate obj))
+	      (else #f)))))
+
+  (define (condition-accessor rtd proc)
+    (let ((rtd-predicate (record-predicate rtd)))
+      (lambda (obj)
+	(cond ((rtd-predicate obj) (proc obj))
+	      ((compound-condition? obj) 
+	       (and=> (find rtd-predicate simple-conditions obj) proc))
+	      (else #f)))))
+
+  (define-condition-type &message &condition 
+    make-message-condition message-condition? 
+    (message condition-message))
+
+  (define-condition-type &warning &condition make-warning warning?)
+
+  (define &serious (@@ (rnrs records procedural) &serious))
+  (define make-serious-condition 
+    (@@ (rnrs records procedural) make-serious-condition))
+  (define serious-condition? (@@ (rnrs records procedural) serious-condition?))
+
+  (define-condition-type &error &serious make-error error?)
+
+  (define &violation (@@ (rnrs records procedural) &violation))
+  (define make-violation (@@ (rnrs records procedural) make-violation))
+  (define violation? (@@ (rnrs records procedural) violation?))
+
+  (define &assertion (@@ (rnrs records procedural) &assertion))
+  (define make-assertion-violation 
+    (@@ (rnrs records procedural) make-assertion-violation))
+  (define assertion-violation? 
+    (@@ (rnrs records procedural) assertion-violation?))
+
+  (define-condition-type &irritants &condition 
+    make-irritants-condition irritants-condition?
+    (irritants condition-irritants))
+
+  (define-condition-type &who &condition
+    make-who-condition who-condition?
+    (who condition-who))
+
+  (define-condition-type &non-continuable &violation
+    make-non-continuable-violation
+    non-continuable-violation?)
+
+  (define-condition-type &implementation-restriction
+    &violation
+    make-implementation-restriction-violation
+    implementation-restriction-violation?)
+
+  (define-condition-type &lexical &violation
+    make-lexical-violation lexical-violation?)
+
+  (define-condition-type &syntax &violation
+    make-syntax-violation syntax-violation
+    (form syntax-violation-form)
+    (subform syntax-violation-subform))
+
+  (define-condition-type &undefined &violation
+    make-undefined-violation undefined-violation?))

module/rnrs/6/exceptions.scm

@@ -0,0 +1,51 @@
+;;; exceptions.scm --- The R6RS exceptions 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 exceptions (6))
+  (export with-exception-handler raise raise-continuable)
+  (import (rnrs base (6))
+          (rnrs conditions (6))
+	  (rnrs records procedural (6))
+	  (only (guile) with-throw-handler))
+
+  (define raise (@@ (rnrs records procedural) r6rs-raise))
+  (define raise-continuable 
+    (@@ (rnrs records procedural) r6rs-raise-continuable))
+  (define raise-object-wrapper? 
+    (@@ (rnrs records procedural) raise-object-wrapper?))
+  (define raise-object-wrapper-obj
+    (@@ (rnrs records procedural) raise-object-wrapper-obj))
+  (define raise-object-wrapper-continuation
+    (@@ (rnrs records procedural) raise-object-wrapper-continuation))
+
+  (define (with-exception-handler handler thunk)
+    (with-throw-handler 'r6rs:exception
+     thunk
+     (lambda (key . args)
+       (if (and (not (null? args))
+		(raise-object-wrapper? (car args)))
+	   (let* ((cargs (car args))
+		  (obj (raise-object-wrapper-obj cargs))
+		  (continuation (raise-object-wrapper-continuation cargs))
+		  (handler-return (handler obj)))
+	     (if continuation
+		 (continuation handler-return)
+		 (raise (make-non-continuable-violation))))
+	   *unspecified*))))
+)

module/rnrs/6/syntax-case.scm

@@ -0,0 +1,55 @@
+;;; syntax-case.scm --- R6RS support for `syntax-case' macros
+
+;;      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 syntax-case (6))
+  (export make-variable-transformer
+	  syntax-case
+	  syntax
+	  
+	  identifier?
+	  bound-identifier=?
+	  free-identifier=?
+
+	  syntax->datum
+	  datum->syntax
+	  generate-temporaries
+	  with-syntax
+
+	  quasisyntax
+	  unsyntax
+	  unsyntax-splicing
+
+	  syntax-violation)
+  (import (only (guile) syntax-case
+		        syntax
+		        
+		        identifier?
+			bound-identifier=?
+			free-identifier=?
+			
+			syntax->datum
+			datum->syntax
+			generate-temporaries
+			with-syntax
+
+			quasisyntax
+			unsyntax
+			unsyntax-splicing
+
+			syntax-violation)))

module/rnrs/io/6/simple.scm

@@ -0,0 +1,77 @@
+;;; simple.scm --- The R6RS simple I/O 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 io simple (6))
+  (export eof-object 
+          eof-object?
+
+	  call-with-input-file
+	  call-with-output-file
+	  
+	  input-port?
+	  output-port?
+
+	  current-input-port
+	  current-output-port
+	  current-error-port
+
+	  with-input-from-file
+	  with-output-to-file
+
+	  open-input-file
+	  open-output-file
+
+	  close-input-port
+	  close-output-port
+
+	  read-char
+	  peek-char
+	  read
+	  write-char
+	  newline
+	  display
+	  write)
+  (import (only (rnrs io ports) eof-object 
+		                eof-object? 
+ 
+                                input-port? 
+				output-port?)
+          (only (guile) call-with-input-file
+			call-with-output-file
+
+			current-input-port
+			current-output-port
+			current-error-port
+
+			with-input-file
+			with-output-file
+
+			open-input-file
+			open-output-file
+			
+			close-input-port
+			close-output-port
+
+			read-char
+			peek-char
+			read
+			write-char
+			newline
+			display
+			write)))

module/rnrs/records/6/procedural.scm

@@ -0,0 +1,256 @@
+;;; procedural.scm --- Procedural interface to R6RS records
+
+;;      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 records procedural (6))
+  (export make-record-type-descriptor 
+	  record-type-descriptor?
+	  make-record-constructor-descriptor
+	  
+	  record-constructor
+	  record-predicate
+	  record-accessor	  
+	  record-mutator)
+	  
+  (import (rnrs base (6))
+          (only (guile) and=>
+			throw
+			display
+		        make-struct 
+			make-vtable 
+			map
+			simple-format
+			string-append 
+			
+			struct? 
+			struct-ref 
+			struct-set! 
+			struct-vtable
+			vtable-index-layout
+
+                        make-hash-table
+			hashq-ref
+			hashq-set!
+
+			vector->list)
+	  (ice-9 receive)
+	  (only (srfi :1) fold-right split-at take))
+
+  (define (record-rtd record) (struct-ref record 1))
+  (define (record-type-name rtd) (struct-ref rtd 0))
+  (define (record-type-parent rtd) (struct-ref rtd 2))
+  (define (record-type-uid rtd) (struct-ref rtd 1))
+  (define (record-type-generative? rtd) (not (record-type-uid rtd))) 
+  (define (record-type-sealed? rtd) (struct-ref rtd 3))
+  (define (record-type-opaque? rtd) (struct-ref rtd 4))
+  (define (record-type-field-names rtd) (struct-ref rtd 6))
+
+  (define record-type-vtable 
+    (make-vtable "prprprprprprprprpr" 
+		 (lambda (obj port) 
+		   (display "#<r6rs:record-type-vtable>" port))))
+
+  (define record-constructor-vtable 
+    (make-vtable "prprpr"
+		 (lambda (obj port) 
+		   (display "#<r6rs:record-constructor-vtable>" port))))
+
+  (define uid-table (make-hash-table))    
+
+  (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
+    (define fields-vtable
+      (make-vtable (fold-right (lambda (x p) 
+				 (string-append p (case (car x)
+						    ((immutable) "pr")
+						    ((mutable) "pw"))))
+			       "prpr" (vector->list fields))
+		   (lambda (obj port)
+		     (simple-format
+		      port "#<r6rs:record-field-layout-vtable:~A>" name))))
+    (define field-names (map cadr (vector->list fields)))
+    (define late-rtd #f)
+    (define (private-record-predicate obj)       
+      (and (struct? obj)
+	   (let* ((vtable (struct-vtable obj))
+		  (layout (symbol->string
+			   (struct-ref vtable vtable-index-layout))))
+	     (and (>= (string-length layout) 3)
+		  (let ((rtd (struct-ref obj 1)))
+		    (and (record-type-descriptor? rtd)
+			 (or (eq? (struct-ref rtd 7) fields-vtable)
+			     (and=> (struct-ref obj 0)
+				    private-record-predicate))))))))
+
+    (define (field-binder parent-struct . args)
+      (apply make-struct (append (list fields-vtable 0 
+				       parent-struct 
+				       late-rtd) 
+				 args)))
+    (if (and parent (record-type-sealed? parent))
+	(r6rs-raise (make-assertion-violation)))
+
+    (let ((matching-rtd (and uid (hashq-ref uid-table uid))))
+      (if matching-rtd
+	  (if (equal? (list name 
+			    parent 
+			    sealed? 
+			    opaque?
+			    field-names
+			    (struct-ref fields-vtable vtable-index-layout))
+		      (list (record-type-name matching-rtd)
+			    (record-type-parent matching-rtd)
+			    (record-type-sealed? matching-rtd)
+			    (record-type-opaque? matching-rtd)
+			    (record-type-field-names matching-rtd)
+			    (struct-ref (struct-ref matching-rtd 7)
+					vtable-index-layout)))
+	      matching-rtd
+	      (r6rs-raise (make-assertion-violation)))
+
+	  (let ((rtd (make-struct record-type-vtable 0
+				  
+				  name
+				  uid
+				  parent 
+				  sealed? 
+				  opaque?
+				  
+				  private-record-predicate
+				  field-names
+				  fields-vtable
+				  field-binder)))
+	    (set! late-rtd rtd)
+	    (if uid (hashq-set! uid-table uid rtd))
+	    rtd))))
+
+  (define (record-type-descriptor? obj)
+    (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
+
+  (define (make-record-constructor-descriptor rtd 
+					      parent-constructor-descriptor
+					      protocol)
+    (define rtd-arity (length (struct-ref rtd 6)))
+    (define (default-inherited-protocol n)
+      (lambda args
+	(receive 
+          (n-args p-args) 
+	  (split-at args (- (length args) rtd-arity))
+	  (let ((p (apply n n-args)))
+	    (apply p p-args)))))
+    (define (default-protocol p) p)
+    
+    (let* ((prtd (struct-ref rtd 1))
+	   (pcd (or parent-constructor-descriptor
+		    (and=> prtd (lambda (d) (make-record-constructor-descriptor 
+					     prtd #f #f)))))
+	   (prot (or protocol (if pcd 
+				  default-inherited-protocol 
+				  default-protocol))))
+      (make-struct record-constructor-vtable 0 rtd pcd prot)))
+
+  (define (record-constructor rctd)
+    (let* ((rtd (struct-ref rctd 0))
+	   (parent-rctd (struct-ref rctd 1))
+	   (protocol (struct-ref rctd 2)))
+      (protocol 
+       (if parent-rctd
+	   (let ((parent-record-constructor (record-constructor parent-rctd))
+		 (parent-rtd (struct-ref parent-rctd 0)))
+	     (lambda args
+	       (let ((struct (apply parent-record-constructor args)))
+		 (lambda args
+		   (apply (struct-ref rtd 8)
+			  (cons struct args))))))
+	   (lambda args (apply (struct-ref rtd 8) (cons #f args)))))))
+		    
+  (define (record-predicate rtd) (struct-ref rtd 5))
+
+  (define (record-accessor rtd k)
+    (define (record-accessor-inner obj)
+      (and obj 
+	   (or (and (eq? (struct-ref obj 1) rtd) (struct-ref obj (+ k 2)))
+	       (record-accessor-inner (struct-ref obj 0)))))
+    (lambda (obj) (record-accessor-inner obj)))
+
+  (define (record-mutator rtd k)
+    (define (record-mutator-inner obj val)
+      (and obj 
+	   (or (and (eq? (struct-ref obj 1) rtd) (struct-set! obj (+ k 2) val))
+	       (record-mutator-inner (struct-ref obj 0) val))))
+    (let* ((rtd-vtable (struct-ref rtd 7))
+	   (field-layout (symbol->string
+			  (struct-ref rtd-vtable vtable-index-layout))))
+      (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
+	  (r6rs-raise (make-assertion-violation))))
+    (lambda (obj val) (record-mutator-inner obj val)))
+
+  ;; Condition types that are used in the current library.  These are defined
+  ;; here and not in (rnrs conditions) to avoid a circular dependency.
+
+  (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
+  (define &condition-constructor-descriptor 
+    (make-record-constructor-descriptor &condition #f #f))
+
+  (define &serious (make-record-type-descriptor 
+		    '&serious &condition #f #f #f '#()))
+  (define &serious-constructor-descriptor
+    (make-record-constructor-descriptor 
+     &serious &condition-constructor-descriptor #f))
+
+  (define make-serious-condition 
+    (record-constructor &serious-constructor-descriptor))
+  (define serious-condition? (record-predicate &serious))
+
+  (define &violation (make-record-type-descriptor
+		      '&violation &serious #f #f #f '#()))
+  (define &violation-constructor-descriptor
+    (make-record-constructor-descriptor 
+     &violation &serious-constructor-descriptor #f))
+  (define make-violation (record-constructor &violation-constructor-descriptor))
+  (define violation? (record-predicate &violation))
+
+  (define &assertion (make-record-type-descriptor
+		      '&assertion &violation #f #f #f '#()))
+  (define make-assertion-violation 
+    (record-constructor 
+     (make-record-constructor-descriptor
+      &assertion &violation-constructor-descriptor #f)))
+  (define assertion-violation? (record-predicate &assertion))
+
+  ;; Exception wrapper type, along with a wrapping `throw' implementation.
+  ;; These are used in the current library, and so they are defined here and not
+  ;; in (rnrs exceptions) to avoid a circular dependency.
+
+  (define &raise-object-wrapper
+    (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
+				 '#((immutable obj) (immutable continuation))))
+  (define make-raise-object-wrapper 
+    (record-constructor (make-record-constructor-descriptor 
+			 &raise-object-wrapper #f #f)))
+  (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
+  (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
+  (define raise-object-wrapper-continuation 
+    (record-accessor &raise-object-wrapper 1))
+
+  (define (r6rs-raise obj) 
+    (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
+  (define (r6rs-raise-continuable obj)
+    (define (r6rs-raise-continuable-internal continuation)
+      (raise (make-raise-object-wrapper obj continuation)))
+    (call/cc r6rs-raise-continuable-internal))
+)

module/rnrs/records/6/syntactic.scm

@@ -0,0 +1,200 @@
+;;; syntactic.scm --- Syntactic support for R6RS records
+
+;;      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 records syntactic (6))
+  (export define-record-type)
+  (import (only (guile) *unspecified* unspecified? @ @@)
+          (rnrs base (6))
+	  (rnrs lists (6))
+	  (rnrs records procedural (6))
+	  (rnrs syntax-case (6))
+	  (only (srfi :1) take))
+
+  (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 ...))
+	((_ record-name record-clause ...)
+	 (let* ((record-name-sym (syntax->datum #'record-name))
+		(constructor-name 
+		 (datum->syntax 
+		  #'record-name (guess-constructor-name record-name-sym)))
+		(predicate-name 
+		 (datum->syntax 
+		  #'record-name (guess-predicate-name record-name-sym))))
+	   #`(define-record-type0 
+	       (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)))
+      (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))
+	  
+      (syntax-case stx ()
+	((_ (record-name constructor-name predicate-name) record-clause ...)
+	 (let loop ((fields *unspecified*)
+		    (parent *unspecified*)
+		    (protocol *unspecified*)
+		    (sealed *unspecified*)
+		    (opaque *unspecified*)
+		    (nongenerative *unspecified*)
+		    (constructor *unspecified*)
+		    (parent-rtd *unspecified*)
+		    (record-clauses (syntax->datum #'(record-clause ...))))
+	   (if (null? record-clauses)
+	       (let
+		((field-names
+		  (datum->syntax 
+		   #'record-name
+		   (if (unspecified? fields) '() 
+		       (list->vector (map (lambda (x) (take x 2)) fields)))))
+		 (field-accessors
+		  (fold-left (lambda (x c lst) 
+			       (cons #`(define #,(datum->syntax 
+						  #'record-name (caddr x))
+					 (record-accessor record-name #,c))
+				     lst))
+			     '() fields (sequence (length fields))))
+		 (field-mutators
+		  (fold-left (lambda (x c lst) 
+			       (if (cadddr x)
+				   (cons #`(define #,(datum->syntax 
+						      #'record-name (cadddr x))
+					     (record-mutator record-name #,c))
+					 lst)
+				   lst))
+			     '() fields (sequence (length fields))))
+		 (parent (datum->syntax 
+			  #'record-name (if (unspecified? parent) #f parent)))
+		 (protocol (datum->syntax
+			    #'record-name (if (unspecified? protocol) 
+					      #f protocol)))
+		 (uid (datum->syntax 
+		       #'record-name (if (unspecified? nongenerative) 
+					 #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)))))
+		  
+		#`(begin 
+		    (define record-name 
+		      (make-record-type-descriptor 
+		       #,(datum->syntax 
+			  stx (list 'quote (syntax->datum #'record-name)))
+		       #,parent #,uid #,sealed? #,opaque? 
+		       #,field-names))
+		    (define constructor-name 
+		      (record-constructor
+		       (make-record-constructor-descriptor 
+			record-name #,parent-cd #,protocol)))
+		    (define predicate-name (record-predicate record-name))
+		    #,@field-accessors
+		    #,@field-mutators))
+	       (let ((cr (car record-clauses)))
+		 (case (car cr)
+		   ((fields) 
+		    (if (unspecified? fields)
+			(loop (process-fields (syntax->datum #'record-name) 
+					      (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)))
+		   ((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))))))))))
+)

test-suite/Makefile.am

@@ -79,6 +79,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/r6rs-arithmetic-bitwise.test	\
 	    tests/r6rs-control.test		\
 	    tests/r6rs-ports.test		\
+	    tests/r6rs-records-procedural.test	\
 	    tests/rnrs-libraries.test		\
 	    tests/ramap.test			\
 	    tests/reader.test			\

test-suite/tests/r6rs-records-procedural.test

@@ -0,0 +1,213 @@
+;;; r6rs-control.test --- Test suite for R6RS (rnrs control)
+
+;;      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-procedural)
+  :use-module ((rnrs conditions) :version (6))
+  :use-module ((rnrs exceptions) :version (6))
+  :use-module ((rnrs records procedural) :version (6))
+  :use-module (test-suite lib))
+
+(define :point (make-record-type-descriptor 
+		'point #f #f #f #f '#((mutable x) (mutable y))))
+(define :point-cd (make-record-constructor-descriptor :point #f #f))
+
+(define :voxel (make-record-type-descriptor 
+		'voxel :point #f #f #f '#((mutable z))))
+(define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f))
+
+(with-test-prefix "make-record-type-descriptor"
+  (pass-if "simple"
+    (let* ((:point-cd (make-record-constructor-descriptor :point #f #f))
+	   (make-point (record-constructor :point-cd))
+	   (point? (record-predicate :point))
+	   (point-x (record-accessor :point 0))
+	   (point-y (record-accessor :point 1))
+	   (point-x-set! (record-mutator :point 0))
+	   (point-y-set! (record-mutator :point 1))
+	   (p1 (make-point 1 2)))
+      (point? p1)
+      (eqv? (point-x p1) 1)
+      (eqv? (point-y p1) 2)
+      (unspecified? (point-x-set! p1 5))
+      (eqv? (point-x p1) 5)))
+
+  (pass-if "sealed records cannot be subtyped"
+    (let* ((:sealed-point (make-record-type-descriptor 
+			   'sealed-point #f #f #t #f '#((mutable x) 
+							(mutable y))))
+	   (success #f))
+      (call/cc 
+       (lambda (continuation)
+	 (with-exception-handler
+	  (lambda (condition) 
+	    (set! success (assertion-violation? condition))
+	    (continuation))
+	  (lambda () (make-record-type-descriptor
+		      'sealed-point-subtype :sealed-point #f #f #f
+		      '#((mutable z)))))))
+      success))
+
+  (pass-if "non-generative records with same uid are eq"
+    (let* ((:rtd-1 (make-record-type-descriptor 
+		    '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)))
+
+  (pass-if "&assertion raised on conflicting non-generative types"
+    (let* ((:rtd-1 (make-record-type-descriptor
+		    'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
+	   (success 0)
+	   (check-definition
+	    (lambda (thunk)
+	      (call/cc 
+	       (lambda (continuation)
+		 (with-exception-handler
+		  (lambda (condition)
+		    (if (assertion-violation? condition)
+			(set! success (+ success 1)))
+		    (continuation))
+		  thunk))))))
+      (check-definition
+       (lambda () 
+	 (make-record-type-descriptor
+	  'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
+      (check-definition
+       (lambda ()
+	 (make-record-type-descriptor
+	  'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
+      (check-definition
+       (lambda ()
+	 (make-record-type-descriptor
+	  'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
+      (check-definition
+       (lambda ()
+	 (make-record-type-descriptor
+	  'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
+      (check-definition
+       (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
+      (check-definition
+       (lambda () 
+	 (make-record-type-descriptor 
+	  'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
+      (check-definition
+       (lambda () 
+	 (make-record-type-descriptor 
+	  'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
+      (eqv? success 7))))
+
+(with-test-prefix "record-type-descriptor?"
+  (pass-if "simple"
+    (record-type-descriptor? 
+     (make-record-type-descriptor 'test #f #f #f #f '#()))))
+
+(with-test-prefix "record-constructor"
+  (pass-if "simple"
+    (let* ((make-point (record-constructor :point-cd))
+	   (point? (record-predicate :point))
+	   (point-x (record-accessor :point 0))
+	   (point-y (record-accessor :point 1))
+	   (point (make-point 1 2)))
+      (and (point? point)
+	   (eqv? (point-x point) 1)
+	   (eqv? (point-y point) 2))))
+
+  (pass-if "construct record subtype"
+    (let* ((make-voxel (record-constructor :voxel-cd))
+	   (voxel? (record-predicate :voxel))
+	   (voxel-z (record-accessor :voxel 0))
+	   (voxel (make-voxel 1 2 3)))
+      (and (voxel? voxel)
+	   (eqv? (voxel-z voxel) 3)))))
+
+(with-test-prefix "record-predicate"
+  (pass-if "simple"
+    (let* ((make-point (record-constructor :point-cd))
+	   (point (make-point 1 2))
+	   (point? (record-predicate :point)))
+      (point? point)))
+
+  (pass-if "predicate returns true on subtype"
+    (let* ((make-voxel (record-constructor :voxel-cd))
+	   (voxel (make-voxel 1 2 3))
+	   (point? (record-predicate :point)))
+      (point? voxel)))
+
+  (pass-if "predicate returns false on supertype"
+    (let* ((make-point (record-constructor :point-cd))
+	   (point (make-point 1 2))
+	   (voxel? (record-predicate :voxel)))
+      (not (voxel? point)))))
+
+(with-test-prefix "record-accessor"
+  (pass-if "simple"
+    (let* ((make-point (record-constructor :point-cd))
+	   (point (make-point 1 2))
+	   (point-x (record-accessor :point 0))
+	   (point-y (record-accessor :point 1)))
+      (and (eqv? (point-x point) 1)
+	   (eqv? (point-y point) 2))))
+
+  (pass-if "accessor for supertype applied to subtype"
+    (let* ((make-voxel (record-constructor :voxel-cd))
+	   (voxel (make-voxel 1 2 3))
+	   (point-x (record-accessor :point 0))
+	   (point-y (record-accessor :point 1)))
+      (and (eqv? (point-x voxel) 1)
+	   (eqv? (point-y voxel) 2)))))
+
+(with-test-prefix "record-mutator"
+  (pass-if "simple"
+    (let* ((make-point (record-constructor :point-cd))
+	   (point (make-point 1 2))
+	   (point-set-x! (record-mutator :point 0))
+	   (point-set-y! (record-mutator :point 1))
+	   (point-x (record-accessor :point 0))
+	   (point-y (record-accessor :point 1)))
+      (point-set-x! point 3)
+      (point-set-y! point 4)
+      (and (eqv? (point-x point) 3)
+	   (eqv? (point-y point) 4))))
+
+  (pass-if "&assertion raised on request for immutable field"
+    (let* ((:immutable-point (make-record-type-descriptor 
+			      'point #f #f #f #f '#((immutable x) 
+						    (immutable y))))
+	   (success #f))
+      (call/cc 
+       (lambda (continuation)
+	 (with-exception-handler
+	  (lambda (condition) 
+	    (set! success (assertion-violation? condition))
+	    (continuation))
+	  (lambda () (record-mutator :immutable-point 0)))))
+      success))
+	 
+  (pass-if "mutator for supertype applied to subtype"
+    (let* ((make-voxel (record-constructor :voxel-cd))
+	   (voxel (make-voxel 1 2 3))
+	   (point-set-x! (record-mutator :point 0))
+	   (point-set-y! (record-mutator :point 1))
+	   (point-x (record-accessor :point 0))
+	   (point-y (record-accessor :point 1)))
+      (point-set-x! voxel 3)
+      (point-set-y! voxel 4)
+      (and (eqv? (point-x voxel) 3)
+	   (eqv? (point-y voxel) 4)))))
+