[Guile-commits] 02/04: make-record-type does more validation on the fields

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f116bd100915a605ce75d6b4d4b08688a81f1e5b
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 23 14:23:50 2019 +0200

    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.
---
 module/ice-9/boot-9.scm       | 44 ++++++++++++++++++++++++++++++++++++-------
 module/system/base/syntax.scm |  6 +++---
 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 0238381..8dd3b38 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 0bc16e5..9d4be1a 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 625a3db..f88c7df 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"