diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-03-10 01:36:15 -0500 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-05-20 21:18:02 -0400 |
commit | 55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1 (patch) | |
tree | b1ad3d9c98c0c2237afe95856e24c3772e94350d /module/rnrs/records | |
parent | 8b58ea453916338a60b8e8cc8d785c82a801b4ae (diff) | |
download | guile-55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1.tar.gz |
Implementation and test cases for the R6RS (rnrs records inspection)
library.
* module/Makefile.am: Add module/rnrs/records/6/inspection.scm to RNRS_SOURCES.
* module/rnrs/records/6/inspection.scm: New file.
* module/rnrs/records/6/procedural.scm: Assorted refactoring:
Create index constants for record, rtd, and rcd field indexes;
record-type-vtable, record-constructor-vtable: More informative display
names;
(make-record-type-descriptor): fold left, not right when creating vtable;
store field names as vector, not list;
detect opaque parents
* test-suite/Makefile.am: Add test-suite/tests/r6rs-records-inspection.test to
SCM_TESTS.
* test-suite/tests/r6rs-records-inspection.test: New file.
Diffstat (limited to 'module/rnrs/records')
-rw-r--r-- | module/rnrs/records/6/inspection.scm | 83 | ||||
-rw-r--r-- | module/rnrs/records/6/procedural.scm | 126 |
2 files changed, 157 insertions, 52 deletions
diff --git a/module/rnrs/records/6/inspection.scm b/module/rnrs/records/6/inspection.scm new file mode 100644 index 000000000..ee9f1f097 --- /dev/null +++ b/module/rnrs/records/6/inspection.scm @@ -0,0 +1,83 @@ +;;; inspection.scm --- Inspection 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 inspection (6)) + (export record? + record-rtd + record-type-name + record-type-parent + record-type-uid + record-type-generative? + record-type-sealed? + record-type-opaque? + record-type-field-names + record-field-mutable?) + (import (rnrs base (6)) + (rnrs conditions (6)) + (rnrs exceptions (6)) + (rnrs records procedural (6)) + (only (guile) struct-ref vtable-index-layout)) + + (define record-internal? (@@ (rnrs records procedural) record-internal?)) + + (define record-index-rtd (@@ (rnrs records procedural) record-index-rtd)) + + (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name)) + (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent)) + (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid)) + (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?)) + (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?)) + (define rtd-index-field-names + (@@ (rnrs records procedural) rtd-index-field-names)) + (define rtd-index-field-vtable + (@@ (rnrs records procedural) rtd-index-field-vtable)) + + (define (record? obj) + (and (record-internal? obj) + (not (record-type-opaque? (struct-ref obj record-index-rtd))))) + + (define (record-rtd record) + (or (and (record-internal? record) + (let ((rtd (struct-ref record record-index-rtd))) + (and (not (struct-ref rtd rtd-index-opaque?)) rtd))) + (raise (make-assertion-violation)))) + + (define (ensure-rtd rtd) + (if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation)))) + + (define (record-type-name rtd) + (ensure-rtd rtd) (struct-ref rtd rtd-index-name)) + (define (record-type-parent rtd) + (ensure-rtd rtd) (struct-ref rtd rtd-index-parent)) + (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid)) + (define (record-type-generative? rtd) + (ensure-rtd rtd) (and (record-type-uid rtd) #t)) + (define (record-type-sealed? rtd) + (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?)) + (define (record-type-opaque? rtd) + (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?)) + (define (record-type-field-names rtd) + (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names)) + (define (record-field-mutable? rtd k) + (ensure-rtd rtd) + (let ((vt (struct-ref rtd rtd-index-field-vtable))) + (eqv? (string-ref (symbol->string (struct-ref vt vtable-index-layout)) + (+ (* 2 (+ k 2)) 1)) + #\w))) +) diff --git a/module/rnrs/records/6/procedural.scm b/module/rnrs/records/6/procedural.scm index 01c94de83..a14842e1c 100644 --- a/module/rnrs/records/6/procedural.scm +++ b/module/rnrs/records/6/procedural.scm @@ -49,62 +49,78 @@ vector->list) (ice-9 receive) - (only (srfi :1) fold-right split-at take)) + (only (srfi :1) fold 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-internal? obj) + (and (struct? obj) + (let* ((vtable (struct-vtable obj)) + (layout (symbol->string + (struct-ref vtable vtable-index-layout)))) + (and (>= (string-length layout) 4) + (let ((rtd (struct-ref obj record-index-rtd))) + (and (record-type-descriptor? rtd))))))) + + (define record-index-parent 0) + (define record-index-rtd 1) + + (define rtd-index-name 0) + (define rtd-index-uid 1) + (define rtd-index-parent 2) + (define rtd-index-sealed? 3) + (define rtd-index-opaque? 4) + (define rtd-index-predicate 5) + (define rtd-index-field-names 6) + (define rtd-index-field-vtable 7) + (define rtd-index-field-binder 8) + + (define rctd-index-rtd 0) + (define rctd-index-parent 1) + (define rctd-index-protocol 2) (define record-type-vtable (make-vtable "prprprprprprprprpr" (lambda (obj port) - (display "#<r6rs:record-type-vtable>" port)))) + (simple-format port "#<r6rs:record-type:~A>" + (struct-ref obj rtd-index-name))))) (define record-constructor-vtable (make-vtable "prprpr" (lambda (obj port) - (display "#<r6rs:record-constructor-vtable>" port)))) + (simple-format port "#<r6rs:record-constructor:~A>" + (struct-ref (struct-ref obj rctd-index-rtd) + rtd-index-name))))) (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)) + (make-vtable (fold (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))) + (simple-format port "#<r6rs:record:~A>" name)))) + (define field-names (list->vector (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)))))))) + (and (record-internal? obj) + (let ((rtd (struct-ref obj record-index-rtd))) + (or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable) + (and=> (struct-ref obj record-index-parent) + 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)) + (if (and parent (struct-ref parent rtd-index-sealed?)) (r6rs-raise (make-assertion-violation))) - (let ((matching-rtd (and uid (hashq-ref uid-table uid)))) + (let ((matching-rtd (and uid (hashq-ref uid-table uid))) + (opaque? (or opaque? (and parent (struct-ref + parent rtd-index-opaque?))))) (if matching-rtd (if (equal? (list name parent @@ -112,12 +128,13 @@ 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) + (list (struct-ref matching-rtd rtd-index-name) + (struct-ref matching-rtd rtd-index-parent) + (struct-ref matching-rtd rtd-index-sealed?) + (struct-ref matching-rtd rtd-index-opaque?) + (struct-ref matching-rtd rtd-index-field-names) + (struct-ref (struct-ref matching-rtd + rtd-index-field-vtable) vtable-index-layout))) matching-rtd (r6rs-raise (make-assertion-violation))) @@ -144,7 +161,7 @@ (define (make-record-constructor-descriptor rtd parent-constructor-descriptor protocol) - (define rtd-arity (length (struct-ref rtd 6))) + (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names))) (define (default-inherited-protocol n) (lambda args (receive @@ -154,7 +171,7 @@ (apply p p-args))))) (define (default-protocol p) p) - (let* ((prtd (struct-ref rtd 1)) + (let* ((prtd (struct-ref rtd rtd-index-parent)) (pcd (or parent-constructor-descriptor (and=> prtd (lambda (d) (make-record-constructor-descriptor prtd #f #f))))) @@ -164,35 +181,40 @@ (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))) + (let* ((rtd (struct-ref rctd rctd-index-rtd)) + (parent-rctd (struct-ref rctd rctd-index-parent)) + (protocol (struct-ref rctd rctd-index-protocol))) (protocol (if parent-rctd (let ((parent-record-constructor (record-constructor parent-rctd)) - (parent-rtd (struct-ref parent-rctd 0))) + (parent-rtd (struct-ref parent-rctd rctd-index-rtd))) (lambda args (let ((struct (apply parent-record-constructor args))) (lambda args - (apply (struct-ref rtd 8) + (apply (struct-ref rtd rtd-index-field-binder) (cons struct args)))))) - (lambda args (apply (struct-ref rtd 8) (cons #f args))))))) + (lambda args (apply (struct-ref rtd rtd-index-field-binder) + (cons #f args))))))) - (define (record-predicate rtd) (struct-ref rtd 5)) + (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate)) (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))))) + (if (not (record-internal? obj)) + (r6rs-raise (make-assertion-violation))) + (if (eq? (struct-ref obj record-index-rtd) rtd) + (struct-ref obj (+ k 2)) + (record-accessor-inner (struct-ref obj record-index-parent)))) (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)) + (or (and (eq? (struct-ref obj record-index-rtd) rtd) + (struct-set! obj (+ k 2) val)) + (record-mutator-inner (struct-ref obj record-index-parent) + val)))) + (let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable)) (field-layout (symbol->string (struct-ref rtd-vtable vtable-index-layout)))) (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w)) |