guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 16/88: define-generic, define-extended-generic are hygie


From: Andy Wingo
Subject: [Guile-commits] 16/88: define-generic, define-extended-generic are hygienic syntax
Date: Fri, 23 Jan 2015 15:25:26 +0000

wingo pushed a commit to branch master
in repository guile.

commit 7cb88cbc922ebaeefe4a33da17b97d85522601a9
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 4 15:35:25 2015 -0500

    define-generic, define-extended-generic are hygienic syntax
    
    * module/oop/goops.scm (define-generic, define-extended-generic):
      (define-extended-generics): Reimplement using syntax-case.
---
 module/oop/goops.scm |   55 ++++++++++++++++++++++++++++---------------------
 1 files changed, 31 insertions(+), 24 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 000294e..15bbf95 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -732,30 +732,37 @@
 ;; Apparently the desired semantics are that we extend previous
 ;; procedural definitions, but that if `name' was already a generic, we
 ;; overwrite its definition.
-(define-macro (define-generic name)
-  (if (not (symbol? name))
-      (goops-error "bad generic function name: ~S" name))
-  `(define ,name
-     (if (and (defined? ',name) (is-a? ,name <generic>))
-         (make <generic> #:name ',name)
-         (ensure-generic (if (defined? ',name) ,name #f) ',name))))
-
-(define-macro (define-extended-generic name val)
-  (if (not (symbol? name))
-      (goops-error "bad generic function name: ~S" name))
-  `(define ,name (make-extended-generic ,val ',name)))
-
-(define-macro (define-extended-generics names . args)
-  (let ((prefixes (get-keyword #:prefix args #f)))
-    (if prefixes
-        `(begin
-           ,@(map (lambda (name)
-                    `(define-extended-generic ,name
-                       (list ,@(map (lambda (prefix)
-                                      (symbol-append prefix name))
-                                    prefixes))))
-                  names))
-        (goops-error "no prefixes supplied"))))
+(define-syntax define-generic
+  (lambda (x)
+    (syntax-case x ()
+      ((define-generic name) (symbol? (syntax->datum #'name))
+       #'(define name
+           (if (and (defined? 'name) (is-a? name <generic>))
+               (make <generic> #:name 'name)
+               (ensure-generic (if (defined? 'name) name #f) 'name)))))))
+
+(define-syntax define-extended-generic
+  (lambda (x)
+    (syntax-case x ()
+      ((define-extended-generic name val) (symbol? (syntax->datum #'name))
+       #'(define name (make-extended-generic val 'name))))))
+
+(define-syntax define-extended-generics
+  (lambda (x)
+    (define (id-append ctx a b)
+      (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+    (syntax-case x ()
+      ((define-extended-generic (name ...) #:prefix (prefix ...))
+       (and (and-map symbol? (syntax->datum #'(name ...)))
+            (and-map symbol? (syntax->datum #'(prefix ...))))
+       (with-syntax ((((val ...)) (map (lambda (name)
+                                         (map (lambda (prefix)
+                                                (id-append name prefix name))
+                                              #'(prefix ...)))
+                                       #'(name ...))))
+         #'(begin
+             (define-extended-generic name (list val ...))
+             ...))))))
 
 (define* (make-generic #:optional name)
   (make <generic> #:name name))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]