mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Julian Graham
parent
aa439b3908
commit
ce543a9f70
9 changed files with 1061 additions and 1 deletions
|
|
@ -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
|
||||
|
|
|
|||
201
module/rnrs/6/conditions.scm
Normal file
201
module/rnrs/6/conditions.scm
Normal file
|
|
@ -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?))
|
||||
51
module/rnrs/6/exceptions.scm
Normal file
51
module/rnrs/6/exceptions.scm
Normal file
|
|
@ -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*))))
|
||||
)
|
||||
55
module/rnrs/6/syntax-case.scm
Normal file
55
module/rnrs/6/syntax-case.scm
Normal file
|
|
@ -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)))
|
||||
77
module/rnrs/io/6/simple.scm
Normal file
77
module/rnrs/io/6/simple.scm
Normal file
|
|
@ -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)))
|
||||
256
module/rnrs/records/6/procedural.scm
Normal file
256
module/rnrs/records/6/procedural.scm
Normal file
|
|
@ -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))
|
||||
)
|
||||
200
module/rnrs/records/6/syntactic.scm
Normal file
200
module/rnrs/records/6/syntactic.scm
Normal file
|
|
@ -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))))))))))
|
||||
)
|
||||
|
|
@ -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 \
|
||||
|
|
|
|||
213
test-suite/tests/r6rs-records-procedural.test
Normal file
213
test-suite/tests/r6rs-records-procedural.test
Normal file
|
|
@ -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)))))
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue