From: Chris Hanson Date: Sun, 22 Sep 2019 21:14:02 +0000 (-0700) Subject: Restore compatibility with SRFI 131. X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~43 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3cf6d6a1de3a120bf515f7cd1d1b3fdde496b3c2;p=mit-scheme.git Restore compatibility with SRFI 131. Also add some tests for records, and fix several bugs revealed by them. --- diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index ea33c9048..4a985e385 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -904,10 +904,10 @@ USA. (scons-call (scons-close 'guarantee) pred-name object accessor)) (scons-call (scons-close '%record-ref) object index))))) (list - (scons-define - (scons-call (scons-close 'record-accessor) - type-name - (scons-quote name)))))) + (scons-define accessor + (scons-call (scons-close 'record-accessor) + type-name + (scons-quote name)))))) (define (scons-record-modifier modifier type-name parent pred-name name index) (if (and (not parent) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 5d196187a..90bb68a46 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -28,7 +28,7 @@ USA. ;;; package: (runtime record) ;;; adapted from JAR's implementation -;;; conforms to R4RS proposal +;;; conforms to R7RS and SRFI 131 (declare (usual-integrations)) (declare (integrate-external "dispatch-tag")) @@ -43,12 +43,6 @@ USA. (%make-record-type type-name field-specs #f) (begin (guarantee record-type? parent-type 'make-record-type) - (for-each (lambda (field-spec) - (let ((name (field-spec-name field-spec))) - (if (%record-type-field-by-name-no-error parent-type - name) - (error "Duplicate child name:" name)))) - field-specs) (%make-record-type type-name field-specs parent-type))))) (define (valid-field-specs? object) @@ -131,12 +125,7 @@ USA. start-index end-index fields-by-index - (let ((v (vector-copy fields-by-index))) - (sort! v - (lambda (f1 f2) - (symbollist fields-by-index))) (filtered '())) + (if (pair? fields) + (loop (cdr fields) + (if (any (let ((name (field-name (car fields)))) + (lambda (field) + (eq? (field-name field) name))) + filtered) + filtered + (cons (car fields) filtered))) + (let ((v (list->vector filtered))) + (sort! v + (lambda (f1 f2) + (symbol (%record-length record) end) - (%record-type-ref type end))))) + (%record-type-ref record end))))) (if type* (loop type*) type)))) @@ -513,14 +519,14 @@ USA. (vector->list (%record-type-fields-by-index record-type))))) (define (set-value! name value) - (let loop ((fields (cdr all-fields)) (prev all-fields)) - (if (pair? fields) - (if (eq? name (field-name (car fields))) - (begin - (%record-set! record (field-index (car fields)) value) - (set-cdr! prev (cdr fields))) - (loop (cdr fields) fields)) - (error "Duplicate keyword:" name)))) + (let ((field (%record-type-field-by-name record-type name))) + (let loop ((fields (cdr all-fields)) (prev all-fields)) + (if (pair? fields) + (if (eq? field (car fields)) + (set-cdr! prev (cdr fields)) + (loop (cdr fields) fields)) + (error "Duplicate keyword:" name))) + (%record-set! record (field-index field) value))) (do ((kl keyword-list (cddr kl))) ((not (pair? kl)) unspecific) @@ -608,18 +614,6 @@ USA. (define-print-method %record? (standard-print-method '%record)) -(define-print-method record? - (standard-print-method - (lambda (record) - (dispatch-tag-print-name (record-type-descriptor record))))) - -(add-boot-init! - (lambda () - (define-print-method record-type? - (standard-print-method 'record-type - (lambda (type) - (list (dispatch-tag-print-name type))))))) - (define-pp-describer %record? (lambda (record) (let loop ((i (fix:- (%record-length record) 1)) (d '())) @@ -628,13 +622,39 @@ USA. (loop (fix:- i 1) (cons (list i (%record-ref record i)) d)))))) +(define-print-method record? + (standard-print-method + (lambda (record) + (dispatch-tag-print-name (record-type-descriptor record))))) + (define-pp-describer record? (lambda (record) (let ((type (record-type-descriptor record))) - (map (lambda (field-name) - `(,field-name - ,((record-accessor type field-name) record))) - (record-type-field-names type))))) + (map (lambda (field) + `(,(field-name field) + ,(%record-ref record (field-index field)))) + (vector->list (%record-type-fields-by-index type)))))) + +(add-boot-init! + (lambda () + (define-print-method record-type? %print-record-type) + (define-pp-describer record-type? %pp-record-type))) + +(define %print-record-type + (standard-print-method 'record-type + (lambda (type) + (list (dispatch-tag-print-name type))))) + +(define (%pp-record-type record-type) + `((name ,(%dispatch-tag-name record-type)) + (predicate ,(%dispatch-tag->predicate record-type)) + (start-index ,(%record-type-start-index record-type)) + (end-index ,(%record-type-end-index record-type)) + (fields-by-index ,(%record-type-fields-by-index record-type)) + (fields-by-name ,(%record-type-fields-by-name record-type)) + (parent ,(%record-type-parent record-type)) + (instance-marker ,(%record-type-instance-marker record-type)) + (applicator ,(%record-type-applicator record-type)))) ;;; For backwards compatibility: (define (set-record-type-unparser-method! record-type method) diff --git a/tests/check.scm b/tests/check.scm index 44ed686a9..efb307282 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -99,6 +99,7 @@ USA. "runtime/test-promise" "runtime/test-random" "runtime/test-readwrite" + "runtime/test-record" "runtime/test-regsexp" "runtime/test-rgxcmp" "runtime/test-sha3" diff --git a/tests/runtime/test-record.scm b/tests/runtime/test-record.scm new file mode 100644 index 000000000..4e3d050de --- /dev/null +++ b/tests/runtime/test-record.scm @@ -0,0 +1,98 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme 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 +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests of record implementation + +(define-record-type make-t1 t1? (a t1-a) (b t1-b)) +(define make-t1-by-keyword (record-keyword-constructor )) + +(define-record-type ( ) make-t2 t2? (c t2-c) (a t2-a)) +(define make-t2-by-name (record-constructor '(c b a))) +(define make-t2-by-keyword (record-keyword-constructor )) + +(define-test 'record-types + (lambda () + (assert-eqv (record-type-parent ) #f) + (assert-equal (record-type-field-names ) '(a b)) + (assert-eqv (record-type-parent ) ) + (assert-equal (record-type-field-names ) '(a b c a)))) + +(define-test 'root-record + (lambda () + (let ((t1 (make-t1 2 3))) + (assert-true (t1? t1)) + (assert-eqv (t1-a t1) 2) + (assert-eqv (t1-b t1) 3) + (assert-eqv (record-type-descriptor t1) ) + (assert-equal (pp-description t1) '((a 2) (b 3)))))) + +(define-test 'root-record-by-keyword + (lambda () + (assert-error (lambda () (make-t1-by-keyword 'a 3 'b 2 'a 5))) + (let ((t1 (make-t1-by-keyword 'b 2 'a 3))) + (assert-true (t1? t1)) + (assert-eqv (t1-a t1) 3) + (assert-eqv (t1-b t1) 2) + (assert-eqv (record-type-descriptor t1) ) + (assert-equal (pp-description t1) '((a 3) (b 2)))))) + +(define-test 'sub-record + (lambda () + (let ((t2 (make-t2 2 3 5 7))) + (assert-true (t1? t2)) + (assert-eqv (t1-a t2) 2) + (assert-eqv (t1-b t2) 3) + (assert-true (t2? t2)) + (assert-eqv (t2-c t2) 5) + (assert-eqv (t2-a t2) 7) + (assert-eqv (record-type-descriptor t2) ) + (assert-equal (pp-description t2) '((a 2) (b 3) (c 5) (a 7)))))) + +(define-test 'sub-record-by-name + (lambda () + (let ((t2 (make-t2-by-name 2 3 5))) + (assert-true (t1? t2)) + (assert-eqv (t1-a t2) #f) + (assert-eqv (t1-b t2) 3) + (assert-true (t2? t2)) + (assert-eqv (t2-c t2) 2) + (assert-eqv (t2-a t2) 5) + (assert-eqv (record-type-descriptor t2) ) + (assert-equal (pp-description t2) '((a #f) (b 3) (c 2) (a 5)))))) + +(define-test 'sub-record-by-keyword + (lambda () + (assert-error (lambda () (make-t2-by-keyword 'a 2 'b 3 'c 5 'a 7))) + (assert-error (lambda () (make-t2-by-keyword 'a 2 'b 3 'c 5 'c 7))) + (let ((t2 (make-t2-by-keyword 'a 2 'b 3 'c 5))) + (assert-true (t1? t2)) + (assert-eqv (t1-a t2) #f) + (assert-eqv (t1-b t2) 3) + (assert-true (t2? t2)) + (assert-eqv (t2-c t2) 5) + (assert-eqv (t2-a t2) 2) + (assert-eqv (record-type-descriptor t2) ) + (assert-equal (pp-description t2) '((a #f) (b 3) (c 5) (a 2)))))) \ No newline at end of file