[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-73-g58b75e9 |
|
Date: |
Mon, 08 Mar 2010 14:04: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=58b75e94d8964c8538116cd73cc4ef1935718778
The branch, wip-r6rs-libraries has been updated
via 58b75e94d8964c8538116cd73cc4ef1935718778 (commit)
from d05c4f37c07fb9ea54eb12760c147884f6ea8aac (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 58b75e94d8964c8538116cd73cc4ef1935718778
Author: Julian Graham <address@hidden>
Date: Mon Mar 8 09:00:42 2010 -0500
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.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 8 +-
module/rnrs/6/conditions.scm | 201 +++++++++++++++++++
module/rnrs/6/exceptions.scm | 51 +++++
module/rnrs/6/{control.scm => syntax-case.scm} | 48 ++++--
module/rnrs/io/6/simple.scm | 77 +++++++
module/rnrs/records/6/procedural.scm | 256 ++++++++++++++++++++++++
module/rnrs/records/6/syntactic.scm | 200 ++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/r6rs-records-procedural.test | 213 ++++++++++++++++++++
9 files changed, 1041 insertions(+), 14 deletions(-)
create mode 100644 module/rnrs/6/conditions.scm
create mode 100644 module/rnrs/6/exceptions.scm
copy module/rnrs/6/{control.scm => syntax-case.scm} (55%)
create mode 100644 module/rnrs/io/6/simple.scm
create mode 100644 module/rnrs/records/6/procedural.scm
create mode 100644 module/rnrs/records/6/syntactic.scm
create mode 100644 test-suite/tests/r6rs-records-procedural.test
diff --git a/module/Makefile.am b/module/Makefile.am
index 2563375..3d1c968 100644
--- a/module/Makefile.am
+++ b/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
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
new file mode 100644
index 0000000..461984f
--- /dev/null
+++ b/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?))
diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm
new file mode 100644
index 0000000..eeea923
--- /dev/null
+++ b/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*))))
+)
diff --git a/module/rnrs/6/control.scm b/module/rnrs/6/syntax-case.scm
similarity index 55%
copy from module/rnrs/6/control.scm
copy to module/rnrs/6/syntax-case.scm
index 69351c6..91ca600 100644
--- a/module/rnrs/6/control.scm
+++ b/module/rnrs/6/syntax-case.scm
@@ -1,4 +1,4 @@
-;;; control.scm --- The R6RS control structures library
+;;; syntax-case.scm --- R6RS support for `syntax-case' macros
;; Copyright (C) 2010 Free Software Foundation, Inc.
;;
@@ -17,17 +17,39 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(library (rnrs control (6))
- (export when unless do case-lambda)
- (import (rnrs base (6))
- (only (guile) do case-lambda))
+(library (rnrs syntax-case (6))
+ (export make-variable-transformer
+ syntax-case
+ syntax
+
+ identifier?
+ bound-identifier=?
+ free-identifier=?
- (define-syntax when
- (syntax-rules ()
- ((when test result1 result2 ...)
- (if test (begin result1 result2 ...)))))
+ syntax->datum
+ datum->syntax
+ generate-temporaries
+ with-syntax
- (define-syntax unless
- (syntax-rules ()
- ((unless test result1 result2 ...)
- (if (not test) (begin result1 result2 ...))))))
+ 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)))
diff --git a/module/rnrs/io/6/simple.scm b/module/rnrs/io/6/simple.scm
new file mode 100644
index 0000000..cf6c130
--- /dev/null
+++ b/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)))
diff --git a/module/rnrs/records/6/procedural.scm
b/module/rnrs/records/6/procedural.scm
new file mode 100644
index 0000000..01c94de
--- /dev/null
+++ b/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))
+)
diff --git a/module/rnrs/records/6/syntactic.scm
b/module/rnrs/records/6/syntactic.scm
new file mode 100644
index 0000000..838f56a
--- /dev/null
+++ b/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))))))))))
+)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 61658c4..ca48ab2 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -73,6 +73,7 @@ SCM_TESTS = tests/alist.test \
tests/r6rs-arithmetic-bitwise.test \
tests/r6rs-control.test \
tests/r6rs-ports.test \
+ tests/r6rs-records-procedural.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
diff --git a/test-suite/tests/r6rs-records-procedural.test
b/test-suite/tests/r6rs-records-procedural.test
new file mode 100644
index 0000000..a1b5e2f
--- /dev/null
+++ b/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)))))
+
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-73-g58b75e9,
Julian Graham <=