From 4f36ce9635755ad194ed6c84e37b6f2a712fda38 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Fri, 12 Nov 2010 05:42:54 -0500
Subject: [PATCH] Redo `define-cstruct' with proper errors and more concisely.

---
 collects/ffi/unsafe.rkt | 100 ++++++++++++++++------------------------
 1 file changed, 40 insertions(+), 60 deletions(-)

diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt
index f3ecaf241e..66fd34a767 100644
--- a/collects/ffi/unsafe.rkt
+++ b/collects/ffi/unsafe.rkt
@@ -1347,67 +1347,47 @@
                   (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
                           make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
                           list->TYPE list*->TYPE TYPE->list TYPE->list*))))))))
-  (define (identifiers? stx)
-    (andmap identifier? (syntax->list stx)))
-  (define (_-identifier? id stx)
-    (and (identifier? id)
-         (or (regexp-match #rx"^_." (symbol->string (syntax-e id)))
-             (raise-syntax-error #f "cstruct name must begin with a `_'"
-                                 stx id))))
-  ;; there is something wrong with the syntax, this function will find what it is
-  (define (syntax-error stx)
-    (define (check-rest rest)
-      (syntax-case rest ()
-        [() (void)]
-        [else (raise-syntax-error #f "extra arguments given" rest)]))
-    (define (check-alignment alignment)
-      (syntax-case alignment ()
-        [(#:alignment alignment-expr rest ...)
-         (check-rest #'(rest ...))]
-        [else (raise-syntax-error #f "the last argument can only be #:alignment" alignment)]))
-    (define (check-slots slots)
-      (define (check-slot slot)
-        (syntax-case slot ()
-          [(name field) (void)]
-          [else (raise-syntax-error #f "a field must be a pair of a name and a ctype such as [x _int]" slot)]))
-      ;; check that some slots are given
-      (syntax-case slots ()
-        [([name-id expr-id] ... . rest)
-         (when (and (identifiers? #'(name-id ...))
-                    (identifiers? #'(expr-id ...)))
-           (raise-syntax-error #f "fields must be a parenthesized list of name and a ctype such as ([x _int] [y _int])" slots))])
-      (syntax-case slots ()
-        [((slot ...) rest ...)
-         (begin
-           (for ([slot-stx (in-list (syntax->list #'(slot ...)))])
-             (check-slot slot-stx))
-           (check-alignment #'(rest ...)))]
-        [else (raise-syntax-error #f "fields must be a parenthesized list such as ([x _int] [y _int])" slots)]))
-    (define (check-name stx)
-      (syntax-case stx ()
-        [(_ _TYPE rest ...)
-         (check-slots #'(rest ...))]
-        [else (raise-syntax-error #f "a name must be provided to cstruct" stx)]))
-    (check-name stx))
-
+  (define (err what . xs)
+    (apply raise-syntax-error #f
+           (if (list? what) (apply string-append what) what)
+           stx xs))
   (syntax-case stx ()
-    [(_ _TYPE ([slot slot-type] ...))
-     (and (_-identifier? #'_TYPE stx)
-          (identifiers? #'(slot ...)))
-     (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'#f)]
-    [(_ _TYPE ([slot slot-type] ...) #:alignment alignment-expr)
-     (and (_-identifier? #'_TYPE stx)
-          (identifiers? #'(slot ...)))
-     (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'alignment-expr)]
-    [(_ (_TYPE _SUPER) ([slot slot-type] ...))
-     (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
-     (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
-       (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'#f))]
-    [(_ (_TYPE _SUPER) ([slot slot-type] ...) #:alignment alignment-expr)
-     (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
-     (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
-       (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'alignment-expr))]
-    [else (syntax-error stx)]))
+    [(_ type ([slot slot-type] ...) . more)
+     (let-values ([(_TYPE _SUPER)
+                   (syntax-case #'type ()
+                     [(t s) (values #'t #'s)]
+                     [_ (values #'type #f)])]
+                  [(alignment)
+                   (syntax-case #'more ()
+                     [() #'#f]
+                     [(#:alignment) (err "missing expression for #:alignment")]
+                     [(#:alignment a) #'a]
+                     [(#:alignment a x . _) (err "unexpected form" #'x)]
+                     [(x . _) (err (if (keyword? (syntax-e #'x))
+                                     "unknown keyword" "unexpected form")
+                                   #'x)])])
+       (unless (identifier? _TYPE)
+         (err "bad type, expecting a _name identifier or (_name super-ctype)"
+              _TYPE))
+       (unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE)))
+         (err "cstruct name must begin with a `_'" _TYPE))
+       (for ([s (in-list (syntax->list #'(slot ...)))])
+         (unless (identifier? s)
+           (err "bad field name, expecting an identifier identifier" s)))
+       (if _SUPER
+         (make-syntax _TYPE #t
+                      #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
+                      #`(#,_SUPER slot-type ...)
+                      alignment)
+         (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))]
+    ;; specific errors for bad slot specs, leave the rest for a generic error
+    [(_ type (bad ...) . more)
+     (err "bad slot specification, expecting [name ctype]"
+          (ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s]))
+                 (syntax->list #'(bad ...))))]
+    [(_ type bad . more)
+     (err "bad slot specification, expecting a sequence of [name ctype]"
+          #'bad)]))
 
 ;; helper for the above: keep runtime information on structs
 (define cstruct-info