From 3119c5b732596c4e02ccbec099baf2f97722e516 Mon Sep 17 00:00:00 2001
From: Andrew Kent <andmkent@iu.edu>
Date: Sun, 8 Oct 2017 16:33:16 -0400
Subject: [PATCH] better stx errs for/fold and for*/fold

---
 pkgs/racket-test-core/tests/racket/for.rktl | 20 +++++++-
 racket/collects/racket/private/for.rkt      | 55 +++++++++++++--------
 2 files changed, 53 insertions(+), 22 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/for.rktl b/pkgs/racket-test-core/tests/racket/for.rktl
index e1ecdb3699..fa69f4db37 100644
--- a/pkgs/racket-test-core/tests/racket/for.rktl
+++ b/pkgs/racket-test-core/tests/racket/for.rktl
@@ -567,8 +567,24 @@
              exn:fail:contract?
              #rx"starting index less than stopping index, but given a negative step")
 
-;; for/fold syntax checking
-(syntax-test #'(for/fold () bad 1) #rx".*bad sequence binding clauses.*")
+;; for/fold & for*/fold syntax checking
+(syntax-test #'(for/fold () bad 1)
+             #rx".*for/fold:.*bad sequence binding clauses.*")
+(syntax-test #'(for/fold () ([42 '()]) 1)
+             #rx".*for/fold:.*bad sequence binding clause.*")
+(syntax-test #'(for/fold ([0 42] [x 42]) ([z '()]) 1)
+             #rx".*for/fold:.*expected an identifier to bind.*")
+(syntax-test #'(for/fold ([x 42] [x 42]) ([z '()]) 1)
+             #rx".*for/fold:.*duplicate identifier as accumulator binding.*")
+
+(syntax-test #'(for*/fold () bad 1)
+             #rx".*for\\*/fold:.*bad sequence binding clauses.*")
+(syntax-test #'(for*/fold () ([42 '()]) 1)
+             #rx".*for\\*/fold:.*bad sequence binding clause.*")
+(syntax-test #'(for*/fold ([0 42] [x 42]) ([z '()]) 1)
+             #rx".*for\\*/fold:.*expected an identifier to bind.*")
+(syntax-test #'(for*/fold ([x 42] [x 42]) ([z '()]) 1)
+             #rx".*for\\*/fold:.*duplicate identifier as accumulator binding.*")
 
 (syntax-test #'(for/vector ()) #rx".*missing body.*")
 
diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt
index d75c591b57..3afc7fdd3c 100644
--- a/racket/collects/racket/private/for.rkt
+++ b/racket/collects/racket/private/for.rkt
@@ -204,6 +204,22 @@
     (define sequence-specialization-logger
       (make-logger 'sequence-specialization (current-logger)))
 
+    (define (check-identifier-bindings orig-stx ids-stx kind result)
+      (let ([ids (syntax->list ids-stx)])
+        (for-each (lambda (id)
+                    (unless (identifier? id)
+                      (raise-syntax-error
+                       #f
+                       "expected an identifier to bind"
+                       orig-stx
+                       id)))
+                  ids)
+        (let ([dup (check-duplicate-identifier ids)])
+          (when dup
+            (raise-syntax-error #f
+                                (format "duplicate identifier as ~a binding" kind) orig-stx dup)))
+        result))
+
     (define (expand-clause orig-stx clause)
       (define (unpack stx)
         (syntax-case stx ()
@@ -219,20 +235,7 @@
         (define unpacked-clause (unpack clause))
         (syntax-case unpacked-clause (values in-parallel stop-before stop-after :do-in)
           [[(id ...) rhs]
-           (let ([ids (syntax->list #'(id ...))])
-             (for-each (lambda (id)
-                         (unless (identifier? id)
-                           (raise-syntax-error
-                            #f
-                            "expected an identifier to bind"
-                            orig-stx
-                            id)))
-                       ids)
-             (let ([dup (check-duplicate-identifier (syntax->list #'(id ...)))])
-               (when dup
-                 (raise-syntax-error #f
-                                     "duplicate identifier as sequence binding" orig-stx dup)))
-             #f)
+           (check-identifier-bindings orig-stx #'(id ...) "sequence" #f)
            'just-checking]
           [[(id ...) (form . rest)]
            (and use-transformer?
@@ -1539,15 +1542,27 @@
        ;; Otherwise, allow compilation as nested loops, which can be slightly faster:
        #'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest)]))
 
-  (define-syntax for/fold/derived
-    (syntax-rules ()
+  (define-syntax (for/fold/derived stx)
+    (syntax-case stx ()
       [(_ orig-stx ([fold-var finid-init] ...) . rest)
-       (for/foldX/derived/final [orig-stx #f] ([fold-var finid-init] ...) (values* fold-var ...) . rest)]))
+       (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t)
+       (syntax/loc #'orig-stx
+         (for/foldX/derived/final [orig-stx #f] ([fold-var finid-init] ...) (values* fold-var ...) . rest))]
+      [(_ orig-stx (bindings ...) . rst)
+       (raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))]
+      [(_ orig-stx . rst)
+       (raise-syntax-error #f "bad syntax" #'orig-stx)]))
 
-  (define-syntax for*/fold/derived
-    (syntax-rules ()
+  (define-syntax (for*/fold/derived stx)
+    (syntax-case stx ()
       [(_ orig-stx ([fold-var finid-init] ...) . rest)
-       (for/foldX/derived/final [orig-stx #t] ([fold-var finid-init] ...) (values* fold-var ...) . rest)]))
+       (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t)
+       (syntax/loc #'orig-stx
+         (for/foldX/derived/final [orig-stx #t] ([fold-var finid-init] ...) (values* fold-var ...) . rest))]
+      [(_ orig-stx (bindings ...) . rst)
+       (raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))]
+      [(_ orig-stx . rst)
+       (raise-syntax-error #f "bad syntax" #'orig-stx)]))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;  derived `for' syntax