[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 47c8983f08157865a3937722c06acbbb3cbd7621

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=47c8983f08157865a3937722c06acbbb3cbd7621

The branch, syncase-in-boot-9 has been updated
       via  47c8983f08157865a3937722c06acbbb3cbd7621 (commit)
      from  8bb0b3cc9d582c48ed6cb5d123168ffd27ac7cf8 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 47c8983f08157865a3937722c06acbbb3cbd7621
Author: Andy Wingo <address@hidden>
Date:   Thu May 21 13:49:00 2009 +0200

    rewrite `method' as a hygienic macro to re-allow lexical specializers
    
    * module/oop/goops.scm (method): Reimplement as a hygienic macro. This
      seriously took me like 6 hours to figure out. Allows for lexical
      specializers: (let ((<x> ...)) (define-method (foo (arg <x>)) ...)).
    
    * module/oop/goops/compile.scm (next-method?, compile-make-procedure):
      Remove these, as `method' does it all now, hygienically.

-----------------------------------------------------------------------

Summary of changes:
 module/oop/goops.scm         |  134 +++++++++++++++++++++++++++++++-----------
 module/oop/goops/compile.scm |   32 +---------
 2 files changed, 101 insertions(+), 65 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index d7220d4..8c98048 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -477,41 +477,105 @@
            (toplevel-define! 'name (make <generic> #:name 'name)))
        (add-method! name (method args body ...))))))
 
-(define-macro (method args . body)
-  (letrec ((specializers
-           (lambda (ls)
-             (cond ((null? ls) (list (list 'quote '())))
-                   ((pair? ls) (cons (if (pair? (car ls))
-                                         (cadar ls)
-                                         '<top>)
-                                     (specializers (cdr ls))))
-                   (else '(<top>)))))
-          (formals
-           (lambda (ls)
-             (if (pair? ls)
-                 (cons (if (pair? (car ls)) (caar ls) (car ls))
-                       (formals (cdr ls)))
-                 ls))))
-    (let ((make-proc (compile-make-procedure (formals args)
-                                             (specializers args)
-                                             body)))
-      `(make <method>
-         #:specializers (cons* ,@(specializers args))
-         #:formals ',(formals args)
-         #:body ',body
-         #:make-procedure ,make-proc
-         #:procedure ,(and (not make-proc)
-                           ;; that is to say: we set #:procedure if
-                           ;; `compile-make-procedure' returned `#f',
-                           ;; which is the case if `body' does not
-                           ;; contain a call to `next-method'
-                          `(lambda ,(formals args)
-                             ,@(if (null? body)
-                                   ;; This used to be '((begin)), but
-                                   ;; guile's memoizer doesn't like
-                                   ;; (lambda args (begin)).
-                                   '((if #f #f))
-                                   body)))))))
+(define-syntax method
+  (lambda (x)
+    (define (compute-formals args)
+      (let lp ((ls args) (out '()))
+        (syntax-case ls ()
+          (((f s) . rest)  (lp (syntax rest) (cons (syntax f) out)))
+          ((f . rest)      (identifier? (syntax f))
+                           (lp (syntax rest) (cons (syntax f) out)))
+          (()              (reverse out))
+          (tail            (identifier? (syntax tail))
+                           (append (reverse out) (syntax tail))))))
+
+    (define (compute-specializers args)
+      (let lp ((ls args) (out '()))
+        (syntax-case ls ()
+          (((f s) . rest)  (lp (syntax rest) (cons (syntax s) out)))
+          ((f . rest)      (lp (syntax rest) (cons (syntax <top>) out)))
+          (()              (reverse (cons (syntax '()) out)))
+          (tail            (reverse (cons (syntax <top>) out))))))
+
+    (define (find-free-id exp referent)
+      (syntax-case exp ()
+        ((x . y)
+         (or (find-free-id (syntax x) referent)
+             (find-free-id (syntax y) referent)))
+        (x
+         (identifier? (syntax x))
+         (let ((id (datum->syntax (syntax x) referent)))
+           (and (free-identifier=? (syntax x) id) id)))
+        (_ #f)))
+
+    (define (compute-procedure formals body)
+      (syntax-case body ()
+        ((body0 ...)
+         (with-syntax ((formals formals))
+           (syntax (lambda formals body0 ...))))))
+
+    (define (->proper args)
+      (let lp ((ls args) (out '()))
+        (syntax-case ls ()
+          ((x . xs)        (lp (syntax xs) (cons (syntax x) out)))
+          (()              (reverse out))
+          (tail            (reverse (cons (syntax tail) out))))))
+
+    (define (compute-make-procedure formals body next-method)
+      (syntax-case body ()
+        ((body ...)
+         (with-syntax ((next-method next-method))
+           (syntax-case formals ()
+             ((formal ...)
+              (syntax
+               (lambda (real-next-method)
+                 (lambda (formal ...)
+                   (let ((next-method (lambda args
+                                        (if (null? args)
+                                            (real-next-method formal ...)
+                                            (apply real-next-method args)))))
+                     body ...)))))
+             (formals
+              (with-syntax (((formal ...) (->proper (syntax formals))))
+                (syntax
+                 (lambda (real-next-method)
+                   (lambda formals
+                     (let ((next-method (lambda args
+                                          (if (null? args)
+                                              (apply real-next-method formal 
...)
+                                              (apply real-next-method args)))))
+                       body ...)))))))))))
+
+    (define (compute-procedures formals body)
+      ;; So, our use of this is broken, because it operates on the
+      ;; pre-expansion source code. It's equivalent to just searching
+      ;; for referent in the datums. Ah well.
+      (let ((id (find-free-id body 'next-method)))
+        (if id
+            ;; return a make-procedure
+            (values (syntax #f)
+                    (compute-make-procedure formals body id))
+            (values (compute-procedure formals body)
+                    (syntax #f)))))
+
+    (syntax-case x ()
+      ((_ args) (syntax (method args (if #f #f))))
+      ((_ args body0 body1 ...)
+       (with-syntax ((formals (compute-formals (syntax args)))
+                     ((specializer ...) (compute-specializers (syntax args))))
+         (call-with-values
+             (lambda ()
+               (compute-procedures (syntax formals) (syntax (body0 body1 
...))))
+           (lambda (procedure make-procedure)
+             (with-syntax ((procedure procedure)
+                           (make-procedure make-procedure))
+               (syntax
+                (make <method>
+                  #:specializers (cons* specializer ...)
+                  #:formals 'formals
+                  #:body '(body0 body1 ...)
+                  #:make-procedure make-procedure
+                  #:procedure procedure))))))))))
 
 ;;;
 ;;; {add-method!}
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 3962be4..e6b13c4 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -24,7 +24,7 @@
 (define-module (oop goops compile)
   :use-module (oop goops)
   :use-module (oop goops util)
-  :export (compute-cmethod compile-make-procedure)
+  :export (compute-cmethod)
   :no-backtrace
   )
 
@@ -60,9 +60,7 @@
 ;;; So, for the reader: there basic idea is that, given that the
 ;;; semantics of `next-method' depend on the concrete types being
 ;;; dispatched, why not compile a specific procedure to handle each type
-;;; combination that we see at runtime. There are two compilation
-;;; strategies implemented: one for the memoizer, and one for the VM
-;;; compiler.
+;;; combination that we see at runtime.
 ;;;
 ;;; In theory we can do much better than a bytecode compilation, because
 ;;; we know the *exact* types of the arguments. It's ideal for native
@@ -71,32 +69,6 @@
 ;;; I think this whole generic application mess would benefit from a
 ;;; strict MOP.
 
-;;; Temporary solution---return #f if x doesn't refer to `next-method'.
-(define (next-method? x)
-  (and (pair? x)
-       (or (eq? (car x) 'next-method)
-          (next-method? (car x))
-          (next-method? (cdr x)))))
-
-;; Called by the `method' macro in goops.scm.
-(define (compile-make-procedure formals specializers body)
-  (and (next-method? body)
-       (let ((next-method-sym (gensym " next-method"))
-             (args-sym (gensym)))
-         `(lambda (,next-method-sym)
-            (lambda ,formals
-              (let ((next-method (lambda ,args-sym
-                                   (if (null? ,args-sym)
-                                       ,(if (list? formals)
-                                            `(,next-method-sym ,@formals)
-                                            `(apply
-                                              ,next-method-sym
-                                              ,@(improper->proper formals)))
-                                       (apply ,next-method-sym ,args-sym)))))
-                ,@(if (null? body)
-                      '((begin))
-                      body)))))))
-
 (define (compile-method methods types)
   (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
     (if make-procedure


hooks/post-receive
-- 
GNU Guile