`class' is a hygienic macro

* module/oop/goops.scm (class): Rewrite as a hygienic macro.

module/oop/goops.scm

@@ -593,20 +593,6 @@
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
 
-(define (kw-do-map mapper f kwargs)
-  (define (keywords l)
-    (cond
-     ((null? l) '())
-     ((or (null? (cdr l)) (not (keyword? (car l))))
-      (goops-error "malformed keyword arguments: ~a" kwargs))
-     (else (cons (car l) (keywords (cddr l))))))
-  (define (args l)
-    (if (null? l) '() (cons (cadr l) (args (cddr l)))))
-  ;; let* to check keywords first
-  (let* ((k (keywords kwargs))
-         (a (args kwargs)))
-    (mapper f k a)))
-
 (define (make-class supers slots . options)
   (let* ((name (get-keyword #:name options (make-unbound)))
          (supers (if (not (or-map (lambda (class)
@@ -641,35 +627,43 @@
 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
-(define-macro (class supers . slots)
+(define-syntax class
-  (define (make-slot-definition-forms slots)
+  (lambda (x)
-    (map
+    (define (parse-options options)
-     (lambda (def)
+      (syntax-case options ()
-       (cond
+        (() #'())
-        ((pair? def)
+        ((kw arg . options) (keyword? (syntax->datum #'kw))
-         `(list ',(car def)
+         (with-syntax ((options (parse-options #'options)))
-                ,@(kw-do-map append-map
+           (syntax-case #'kw ()
-                             (lambda (kw arg)
+             (#:init-form
-                               (case kw
+              #'(kw 'arg #:init-thunk (lambda () arg) . options))
-                                 ((#:init-form)
+             (_
-                                  `(#:init-form ',arg
+              #'(kw arg . options)))))))
-                                    #:init-thunk (lambda () ,arg)))
+    (define (check-valid-kwargs args)
-                                 (else (list kw arg))))
+      (syntax-case args ()
-                             (cdr def))))
+        (() #'())
-        (else
+        ((kw arg . args) (keyword? (syntax->datum #'kw))
-         `(list ',def))))
+         #`(kw arg . #,(check-valid-kwargs #'args)))))
-     slots))
+    (define (parse-slots-and-kwargs args)
-  (if (not (list? supers))
+      (syntax-case args ()
-      (goops-error "malformed superclass list: ~S" supers))
+        (()
-  (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
+         #'(() ()))
-        (options (or (find-tail keyword? slots) '())))
+        ((kw . _) (keyword? (syntax->datum #'kw))
-    `(make-class
+         #`(() #,(check-valid-kwargs args)))
-      ;; evaluate super class variables
+        (((name option ...) args ...)
-      (list ,@supers)
+         (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
-      ;; evaluate slot definitions, except the slot name!
+                       ((option ...) (parse-options #'(option ...))))
-      (list ,@(make-slot-definition-forms slots))
+           #'(((list 'name option ...) . slots) kwargs)))
-      ;; evaluate class options
+        ((name args ...) (symbol? (syntax->datum #'name))
-      ,@options)))
+         (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
+           #'(('(name) . slots) kwargs)))))
+    (syntax-case x ()
+      ((class (super ...) arg ...)
+       (with-syntax ((((slot-def ...) (option ...))
+                      (parse-slots-and-kwargs #'(arg ...))))
+         #'(make-class (list super ...)
+                       (list slot-def ...)
+                       option ...))))))
 
 (define-syntax define-class-pre-definition
   (lambda (x)