summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-10-23 14:23:50 +0200
committerAndy Wingo <wingo@pobox.com>2019-10-23 14:42:29 +0200
commitf116bd100915a605ce75d6b4d4b08688a81f1e5b (patch)
tree0e9935f4dae3b206e8c3097bbd40df724f1fe856
parentbebc46be14c99709aafe210704508b285973fdfb (diff)
downloadguile-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.scm44
-rw-r--r--module/system/base/syntax.scm6
-rw-r--r--test-suite/tests/records.test10
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"