Also add some tests for records, and fix several bugs revealed by them.
(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)
;;; 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"))
(%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)
start-index
end-index
fields-by-index
- (let ((v (vector-copy fields-by-index)))
- (sort! v
- (lambda (f1 f2)
- (symbol<? (field-name f1)
- (field-name f2))))
- v)
+ (generate-fields-by-name fields-by-index)
parent-type
#f
#f)))
record?))
type)))
+(define (generate-fields-by-name fields-by-index)
+ (let loop ((fields (reverse (vector->list 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<? (field-name f1)
+ (field-name f2))))
+ v))))
+
(define-integrable (make-field name init index)
(vector name init index))
(let ((type*
(let ((end (%record-type-end-index type)))
(and (fix:> (%record-length record) end)
- (%record-type-ref type end)))))
+ (%record-type-ref record end)))))
(if type*
(loop type*)
type))))
(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)
(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 '()))
(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)
"runtime/test-promise"
"runtime/test-random"
"runtime/test-readwrite"
+ "runtime/test-record"
"runtime/test-regsexp"
"runtime/test-rgxcmp"
"runtime/test-sha3"
--- /dev/null
+#| -*-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
+\f
+(define-record-type <t1> make-t1 t1? (a t1-a) (b t1-b))
+(define make-t1-by-keyword (record-keyword-constructor <t1>))
+
+(define-record-type (<t2> <t1>) make-t2 t2? (c t2-c) (a t2-a))
+(define make-t2-by-name (record-constructor <t2> '(c b a)))
+(define make-t2-by-keyword (record-keyword-constructor <t2>))
+
+(define-test 'record-types
+ (lambda ()
+ (assert-eqv (record-type-parent <t1>) #f)
+ (assert-equal (record-type-field-names <t1>) '(a b))
+ (assert-eqv (record-type-parent <t2>) <t1>)
+ (assert-equal (record-type-field-names <t2>) '(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) <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) <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) <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) <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) <t2>)
+ (assert-equal (pp-description t2) '((a #f) (b 3) (c 5) (a 2))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff