From 55684b5e3b5ceab5b87c46fc9dd2b78637ff13e1 Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Wed, 10 Mar 2010 01:36:15 -0500 Subject: [PATCH] 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. --- module/Makefile.am | 3 +- module/rnrs/records/6/inspection.scm | 83 ++++++++++ module/rnrs/records/6/procedural.scm | 126 +++++++++------ test-suite/Makefile.am | 1 + test-suite/tests/r6rs-records-inspection.test | 148 ++++++++++++++++++ 5 files changed, 308 insertions(+), 53 deletions(-) create mode 100644 module/rnrs/records/6/inspection.scm create mode 100644 test-suite/tests/r6rs-records-inspection.test diff --git a/module/Makefile.am b/module/Makefile.am index 0043562bd..dbcc40505 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -263,10 +263,11 @@ RNRS_SOURCES = \ rnrs/6/syntax-case.scm \ rnrs/arithmetic/6/bitwise.scm \ rnrs/bytevector.scm \ + rnrs/records/6/inspection.scm \ rnrs/records/6/procedural.scm \ rnrs/records/6/syntactic.scm \ rnrs/io/ports.scm \ - rnrs/io.simple.scm + rnrs/io/6/simple.scm EXTRA_DIST += scripts/ChangeLog-2008 EXTRA_DIST += scripts/README 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 "#" port)))) + (simple-format port "#" + (struct-ref obj rtd-index-name))))) (define record-constructor-vtable (make-vtable "prprpr" (lambda (obj port) - (display "#" port)))) + (simple-format port "#" + (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 "#" name)))) - (define field-names (map cadr (vector->list fields))) + (simple-format port "#" 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)) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 107e291db..fa83f9a86 100644 --- a/test-suite/Makefile.am +++ b/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-inspection.test \ tests/r6rs-records-procedural.test \ tests/rnrs-libraries.test \ tests/ramap.test \ diff --git a/test-suite/tests/r6rs-records-inspection.test b/test-suite/tests/r6rs-records-inspection.test new file mode 100644 index 000000000..717bb498d --- /dev/null +++ b/test-suite/tests/r6rs-records-inspection.test @@ -0,0 +1,148 @@ +;;; 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 inspection) :version (6)) + :use-module ((rnrs records procedural) :version (6)) + :use-module (test-suite lib)) + +(with-test-prefix "record?" + (pass-if "record? recognizes non-opaque records" + (let* ((rec (make-record-type-descriptor 'rec #f #f #f #f '#())) + (make-rec (record-constructor + (make-record-constructor-descriptor rec #f #f)))) + (record? (make-rec)))) + + (pass-if "record? doesn't recognize opaque records" + (let* ((rec (make-record-type-descriptor 'rec #f #f #f #t '#())) + (make-rec (record-constructor + (make-record-constructor-descriptor rec #f #f)))) + (not (record? (make-rec))))) + + (pass-if "record? doesn't recognize non-records" (not (record? 'foo)))) + +(with-test-prefix "record-rtd" + (pass-if "simple" + (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #f '#())) + (make-rec (record-constructor + (make-record-constructor-descriptor rtd #f #f)))) + (eq? (record-rtd (make-rec)) rtd))) + + (pass-if "&assertion on opaque record" + (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #t '#())) + (make-rec (record-constructor + (make-record-constructor-descriptor rtd #f #f))) + (success #f)) + (call/cc + (lambda (continuation) + (with-exception-handler + (lambda (condition) + (set! success (assertion-violation? condition)) + (continuation)) + (lambda () (record-rtd (make-rec)))))) + success))) + +(with-test-prefix "record-type-name" + (pass-if "simple" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) + (eq? (record-type-name rtd) 'foo)))) + +(with-test-prefix "record-type-parent" + (pass-if "eq? to parent" + (let* ((rtd-parent (make-record-type-descriptor 'foo #f #f #f #f '#())) + (rtd (make-record-type-descriptor 'bar rtd-parent #f #f #f '#()))) + (eq? (record-type-parent rtd) rtd-parent))) + + (pass-if "#f when parent not present" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) + (not (record-type-parent rtd))))) + +(with-test-prefix "record-type-uid" + (pass-if "eq? to uid" + (let* ((uid (gensym)) + (rtd (make-record-type-descriptor uid #f uid #f #f '#()))) + (eq? (record-type-uid rtd) uid))) + + (pass-if "#f when uid not present" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) + (not (record-type-uid rtd))))) + +(with-test-prefix "record-type-generative?" + (pass-if "#t when uid is not #f" + (let* ((uid (gensym)) + (rtd (make-record-type-descriptor uid #f uid #f #f '#()))) + (record-type-generative? rtd))) + + (pass-if "#f when uid is #f" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) + (not (record-type-generative? rtd))))) + +(with-test-prefix "record-type-sealed?" + (pass-if "#t when sealed? is #t" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #t #f '#()))) + (record-type-sealed? rtd))) + + (pass-if "#f when sealed? is #f" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) + (not (record-type-sealed? rtd))))) + +(with-test-prefix "record-type-opaque?" + (pass-if "#t when opaque? is #t" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #t '#()))) + (record-type-opaque? rtd))) + + (pass-if "#f when opaque? is #f" + (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) + (not (record-type-opaque? rtd)))) + + (pass-if "#t when parent is opaque" + (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #t '#())) + (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f '#()))) + (record-type-opaque? rtd)))) + +(with-test-prefix "record-type-field-names" + (pass-if "simple" + (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f + '#((immutable foo) + (mutable bar))))) + (equal? (record-type-field-names rtd) '#(foo bar)))) + + (pass-if "parent fields not included" + (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f + '#((mutable foo)))) + (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f + '#((immutable bar))))) + (equal? (record-type-field-names rtd) '#(bar)))) + + (pass-if "subtype fields not included" + (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f + '#((mutable foo)))) + (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f + '#((immutable bar))))) + (equal? (record-type-field-names parent-rtd) '#(foo))))) + +(with-test-prefix "record-field-mutable?" + (pass-if "simple" + (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f + '#((mutable foo) + (immutable bar))))) + (and (record-field-mutable? rtd 0) + (not (record-field-mutable? rtd 1))))))