diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-23 14:23:50 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-23 14:42:29 +0200 |
commit | f116bd100915a605ce75d6b4d4b08688a81f1e5b (patch) | |
tree | 0e9935f4dae3b206e8c3097bbd40df724f1fe856 | |
parent | bebc46be14c99709aafe210704508b285973fdfb (diff) | |
download | guile-f116bd100915a605ce75d6b4d4b08688a81f1e5b.tar.gz |
make-record-type does more validation on the fields
* module/ice-9/boot-9.scm (make-record-type): Validate that the fields
are a unique list of symbols. Deprecate passing a string as a type
name.
* module/system/base/syntax.scm (define-record): Update to pass a symbol
as a type name.
* test-suite/tests/records.test (rtd-foo, rtd-fŏŏ, "records"): Adapt to
make record types with symbol names.
-rw-r--r-- | module/ice-9/boot-9.scm | 44 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 6 | ||||
-rw-r--r-- | test-suite/tests/records.test | 10 |
3 files changed, 45 insertions, 15 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 023838133..8dd3b3857 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1298,10 +1298,42 @@ VALUE." (else #()))) + (define (check-fields fields) + (unless (null? fields) + (let ((field (car fields)) + (fields (cdr fields))) + (unless (symbol? field) + (error "expected field to be a symbol" field)) + (when (memq field fields) + (error "duplicate field" field)) + (check-fields fields)))) + + (define (append-fields head tail) + (if (null? head) + tail + (let ((field (car head)) + (tail (append-fields (cdr head) tail))) + (when (memq field tail) + (error "duplicate field" field)) + (cons field tail)))) + (define computed-fields - (if parent - (append (record-type-fields parent) fields) - fields)) + (begin + (check-fields fields) + (if parent + (append-fields (record-type-fields parent) fields) + fields))) + + (define name-sym + (cond + ((symbol? type-name) type-name) + ((string? type-name) + (issue-deprecation-warning + "Passing a string as a type-name to make-record-type is deprecated." + " Pass a symbol instead.") + (string->symbol type-name)) + (else + (error "expected a symbol for record type name" type-name)))) (define rtd (make-struct/no-tail @@ -1310,7 +1342,7 @@ VALUE." (apply string-append (map (lambda (f) "pw") computed-fields))) (or printer default-record-printer) - type-name + name-sym computed-fields #f ; Constructor initialized below. (if final? '(final) '()) @@ -1321,9 +1353,7 @@ VALUE." ;; Temporary solution: Associate a name to the record type descriptor ;; so that the object system can create a wrapper class for it. - (set-struct-vtable-name! rtd (if (symbol? type-name) - type-name - (string->symbol type-name))) + (set-struct-vtable-name! rtd name-sym) rtd) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 0bc16e584..9d4be1aa9 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,6 +1,6 @@ ;;; Guile VM specific syntaxes and utilities -;; Copyright (C) 2001, 2009, 2016 Free Software Foundation, Inc +;; Copyright (C) 2001, 2009, 2016, 2019 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 @@ -65,7 +65,7 @@ slots)) (stem (trim-brackets name))) `(begin - (define ,name (make-record-type ,(symbol->string name) ',slot-names + (define ,name (make-record-type ',name ',slot-names ,@(if printer (list printer) '()))) ,(let* ((reqs (let lp ((slots slots)) (if (or (null? slots) (not (symbol? (car slots)))) @@ -98,7 +98,7 @@ slots)) (stem (trim-brackets name))) `(begin - (define ,name (make-record-type ,(symbol->string name) ',slot-names + (define ,name (make-record-type ',name ',slot-names ,@(if printer (list printer) '()))) (define ,(symbol-append 'make- stem) (let ((slots (list ,@(map (lambda (slot) diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test index 625a3db2e..f88c7dfdb 100644 --- a/test-suite/tests/records.test +++ b/test-suite/tests/records.test @@ -1,6 +1,6 @@ ;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*- ;;;; -;;;; Copyright (C) 2009, 2010, 2019 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2010, 2019 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 @@ -21,7 +21,7 @@ #:use-module (test-suite lib)) ;; ascii names and symbols, custom printer -(define rtd-foo (make-record-type "foo" '(x y) +(define rtd-foo (make-record-type 'foo '(x y) (lambda (s p) (display "#<it is a foo>" p)))) (define make-foo (record-constructor rtd-foo)) @@ -32,7 +32,7 @@ (define set-foo-y! (record-modifier rtd-foo 'y)) ;; non-Latin-1 names and symbols, default printer -(define rtd-fŏŏ (make-record-type "fŏŏ" '(x ȳ))) +(define rtd-fŏŏ (make-record-type 'fŏŏ '(x ȳ))) (define make-fŏŏ (record-constructor rtd-fŏŏ)) (define fŏŏ? (record-predicate rtd-fŏŏ)) (define get-fŏŏ-x (record-accessor rtd-fŏŏ 'x)) @@ -71,10 +71,10 @@ (with-test-prefix "record type name" (pass-if "foo" - (string=? "foo" (record-type-name rtd-foo))) + (string=? "foo" (symbol->string (record-type-name rtd-foo)))) (pass-if "fŏŏ" - (string=? "fŏŏ" (record-type-name rtd-fŏŏ)))) + (string=? "fŏŏ" (symbol->string (record-type-name rtd-fŏŏ))))) (with-test-prefix "printer" |