[Guile-commits] 13/42: `class' is a hygienic macro

[Andy Wingo]

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit 55ee6b224712c9020dd6a4bf43d26e0ba6aa6423
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 4 15:18:39 2015 -0500

    `class' is a hygienic macro
    
    * module/oop/goops.scm (class): Rewrite as a hygienic macro.
---
 module/oop/goops.scm |   82 +++++++++++++++++++++++---------------------------
 1 files changed, 38 insertions(+), 44 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f7ea30f..e5b4a49 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 
2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 
2013, 2014, 2015 Free Software Foundation, Inc.
 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <address@hidden>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -590,20 +590,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)
@@ -638,35 +624,43 @@
 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
-(define-macro (class supers . slots)
-  (define (make-slot-definition-forms slots)
-    (map
-     (lambda (def)
-       (cond
-        ((pair? def)
-         `(list ',(car def)
-                ,@(kw-do-map append-map
-                             (lambda (kw arg)
-                               (case kw
-                                 ((#:init-form)
-                                  `(#:init-form ',arg
-                                    #:init-thunk (lambda () ,arg)))
-                                 (else (list kw arg))))
-                             (cdr def))))
-        (else
-         `(list ',def))))
-     slots))
-  (if (not (list? supers))
-      (goops-error "malformed superclass list: ~S" supers))
-  (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
-        (options (or (find-tail keyword? slots) '())))
-    `(make-class
-      ;; evaluate super class variables
-      (list ,@supers)
-      ;; evaluate slot definitions, except the slot name!
-      (list ,@(make-slot-definition-forms slots))
-      ;; evaluate class options
-      ,@options)))
+(define-syntax class
+  (lambda (x)
+    (define (parse-options options)
+      (syntax-case options ()
+        (() #'())
+        ((kw arg . options) (keyword? (syntax->datum #'kw))
+         (with-syntax ((options (parse-options #'options)))
+           (syntax-case #'kw ()
+             (#:init-form
+              #'(kw 'arg #:init-thunk (lambda () arg) . options))
+             (_
+              #'(kw arg . options)))))))
+    (define (check-valid-kwargs args)
+      (syntax-case args ()
+        (() #'())
+        ((kw arg . args) (keyword? (syntax->datum #'kw))
+         #`(kw arg . #,(check-valid-kwargs #'args)))))
+    (define (parse-slots-and-kwargs args)
+      (syntax-case args ()
+        (()
+         #'(() ()))
+        ((kw . _) (keyword? (syntax->datum #'kw))
+         #`(() #,(check-valid-kwargs args)))
+        (((name option ...) args ...)
+         (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
+                       ((option ...) (parse-options #'(option ...))))
+           #'(((list 'name option ...) . slots) kwargs)))
+        ((name args ...) (symbol? (syntax->datum #'name))
+         (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)