[Guile-commits] 02/02: srfi-35: Generate a unique binding for the constructor.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guile.

commit 76e436c892c7f8f41f36ed6343eb1626ff84e90e
Author: Ludovic Courtès <address@hidden>
Date:   Sat Dec 14 23:56:12 2019 +0100

    srfi-35: Generate a unique binding for the constructor.
    
    Previously we'd get warnings like:
    
      t.scm:11:0: warning: shadows previous definition of 
`unused-constructor-51900bdce47d50c' at /tmp/t.scm:6:0
    
    whenever 'define-condition-type' appeared more than once in a source
    file.
    
    * module/srfi/srfi-35.scm (define-condition-type): Rewrite as
    'syntax-case' and generate UNUSED-CONSTRUCTOR as a function of TYPE.
---
 module/srfi/srfi-35.scm | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index fbbe89e..e430833 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -118,11 +118,20 @@ by C."
   (let ((pred (record-predicate type)))
     (or-map (lambda (x) (and (pred x) x)) (simple-exceptions c))))
 
-(define-syntax-rule (define-condition-type type parent predicate
-                      (field accessor) ...)
-  (define-exception-type type parent
-    unused-constructor predicate
-    (field accessor) ...))
+(define-syntax define-condition-type
+  (lambda (s)
+    (syntax-case s ()
+      ((_ type parent predicate (field accessor) ...)
+       ;; The constructor is unused, but generate a new name for each
+       ;; condition to avoid '-Wshadowed-toplevel' warnings when several
+       ;; condition types are defined in the same compilation unit.
+       (with-syntax ((unused-constructor
+                      (datum->syntax
+                       #'type
+                       (symbol-append '#{ make-}# (syntax->datum #'type)))))
+         #'(define-exception-type type parent
+             unused-constructor predicate
+             (field accessor) ...))))))
 
 (define-syntax condition-instantiation
   ;; Build the `(make-condition type ...)' call.