guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] 02/07: GOOPS: Introduce new forms method* and define-met


From: Mikael Djurfeldt
Subject: [Guile-commits] 02/07: GOOPS: Introduce new forms method* and define-method*
Date: Mon, 25 Nov 2024 15:54:16 -0500 (EST)

mdj pushed a commit to branch main
in repository guile.

commit d619da8c351d80ba153e71aaf51d8d2f9c3584e7
Author: Mikael Djurfeldt <mikael@djurfeldt.com>
AuthorDate: Sun Nov 24 14:54:20 2024 +0100

    GOOPS: Introduce new forms method* and define-method*
    
    * module/oop/goops.scm: Export method* and define-method*.
      (define-method): Extract definitions of helper procedures and place
      them in an eval-when at top level.
      (define-method*): Renamed from last commits define-method and modified
      to invoke method*.
      (define-method): New syntax.
      (parse-keyword-formals): Renamed from parse-formals and modified to
      give keyword methods a specialzers list with tail <top>.
      (parse-formals): Re-introduce the code of previous parse-args.
      (%compute-applicable-methods): Revert change of previous
      commit. Giving keyword methods a specializer tail <top> naturally
      makes original %compute-applicable-methods work also with keyword
      methods (which kind of shows that we have made the correct choices).
      (method*): Renamed from last commit's "method".
      (method): New syntax.
---
 module/oop/goops.scm | 119 +++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 107 insertions(+), 12 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index c0490c84a..db7479ef6 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -33,9 +33,10 @@
   #:use-module ((language tree-il primitives)
                 :select (add-interesting-primitive!))
   #:export-syntax (define-class class standard-define-class
-                    define-generic define-accessor define-method
+                    define-generic define-accessor
+                    define-method define-method*
                     define-extended-generic define-extended-generics
-                    method)
+                    method method*)
   #:export ( ;; The root of everything.
             <top>
             <class> <object>
@@ -2020,8 +2021,7 @@ function."
        (else
         (let lp ((specs specs) (types types))
           (cond
-           ((null? specs)
-            (or (null? types) (method-keyword-formals? m)))
+           ((null? specs) (null? types))
            ((not (pair? specs)) #t)
            ((null? types) #f)
            (else
@@ -2044,6 +2044,36 @@ function."
 (define (toplevel-define! name val)
   (module-define! (current-module) name val))
 
+;;;
+;;; The GOOPS API would have been simpler by introducing keyword formals
+;;; in define-method itself, but in order to align with lambda* and
+;;; define*, we introduce method* and define-method* in parallel to
+;;; method and define-method.
+;;;
+;;; There is some code repetition here. The motivation for that is to
+;;; pay some here in order to speed up loading and compilation of larger
+;;; chunks of GOOPS code as well as to make sure that method*:s are as
+;;; efficient as can be.
+;;;
+;;; A more elegant solution would have been to use something akin to
+;;; Mark H. Weavers macro:
+;;;
+;;; (define-syntax define-method*
+;;;   (lambda (x)
+;;;     (syntax-case x ()
+;;;       ((_ (generic arg-spec ... . tail) body ...)
+;;;        (let-values (((required-arg-specs other-arg-specs)
+;;;                      (break (compose keyword? syntax->datum)
+;;;                             #'(arg-spec ...))))
+;;;          #`(define-method (generic #,@required-arg-specs . rest)
+;;;              (apply (lambda* (#,@other-arg-specs . tail)
+;;;                       body ...)
+;;;                     rest)))))))
+;;;
+;;; With the current state of the compiler, this results in slower code
+;;; than the implementation below since the apply call isn't eliminated.
+;;;
+
 (define-syntax define-method
   (syntax-rules (setter)
     ((_ ((setter name) . args) body ...)
@@ -2066,8 +2096,27 @@ function."
          (toplevel-define! 'name (make <generic> #:name 'name)))
        (add-method! name (method args body ...))))))
 
-(define-syntax method
-  (lambda (x)
+(define-syntax define-method*
+  (syntax-rules (setter)
+    ((_ ((setter name) . args) body ...)
+     (begin
+       (when (or (not (defined? 'name))
+                 (not (is-a? name <accessor>)))
+         (toplevel-define! 'name
+                           (ensure-accessor
+                            (if (defined? 'name) name #f) 'name)))
+       (add-method! (setter name) (method* args body ...))))
+    ((_ (name . args) body ...)
+     (begin
+       (when (or (not (defined? 'name))
+                 (not name))
+         (toplevel-define! 'name (make <generic> #:name 'name)))
+       (add-method! name (method* args body ...))))))
+
+;;; This section of helpers is used by both the method and method* syntax
+;;;
+(eval-when (expand load eval)
+  
     ;; parse-formals METHOD-FORMALS
     ;;
     ;; return (FORMALS SPECIALIZERS KEYWORD-FORMALS)
@@ -2087,7 +2136,7 @@ function."
     ;; are not specializable (which also corresponds to CLOS
     ;; functionality).
     ;;
-    (define (parse-formals method-formals)
+    (define (parse-keyword-formals method-formals)
       (let lp ((ls method-formals) (formals '()) (specializers '()))
         (syntax-case ls ()
           (((f s) . rest)
@@ -2103,9 +2152,8 @@ function."
           ((f . rest)
            (keyword? (syntax->datum #'f))
            (list (reverse formals)
-                 (reverse (cons #''() specializers)) ;to be cons*:ed
+                 (reverse (cons #'<top> specializers)) ;to be cons*:ed
                  (cons #'f #'rest)))
-
           (()
            (list (reverse formals)
                  (reverse (cons #''() specializers))
@@ -2116,6 +2164,27 @@ function."
                  (reverse (cons #'<top> specializers))
                  '())))))
 
+    (define (parse-formals method-formals)
+      (let lp ((ls method-formals) (formals '()) (specializers '()))
+        (syntax-case ls ()
+          (((f s) . rest)
+           (and (identifier? #'f) (identifier? #'s))
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'s specializers)))
+          ((f . rest)
+           (identifier? #'f)
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'<top> specializers)))
+          (()
+           (list (reverse formals)
+                 (reverse (cons #''() specializers))))
+          (tail
+           (identifier? #'tail)
+           (list (append (reverse formals) #'tail)
+                 (reverse (cons #'<top> specializers)))))))
+
     (define (find-free-id exp referent)
       (syntax-case exp ()
         ((x . y)
@@ -2218,24 +2287,50 @@ function."
                     (compute-make-procedure formals keyword-formals body id))
             (values (compute-procedure formals keyword-formals body)
                     #'#f))))
+    )
 
+(define-syntax method
+  (lambda (x)
     (syntax-case x ()
       ((_ formals) #'(method formals (if #f #f)))
       ((_ formals body0 body1 ...)
-       (with-syntax (((formals (specializer ...) keyword-formals)
+       (with-syntax (((formals (specializer ...))
                       (parse-formals #'formals)))
          (call-with-values
              (lambda ()
                (compute-procedures #'formals
-                                   #'keyword-formals
+                                   '()
                                    #'(body0 body1 ...)))
            (lambda (procedure make-procedure)
              (with-syntax ((procedure procedure)
                            (make-procedure make-procedure))
                #`(make <method>
                    #:specializers (cons* specializer ...) ;yes, this
-                   ;; The cons* is needed to get at the value of each
+                   ;; The cons* is needed to get the value of each
                    ;; specializer.
+                   #:formals 'formals ;might be improper
+                   #:keyword-formals? #f
+                   #:body '(body0 body1 ...)
+                   #:make-procedure make-procedure
+                   #:procedure procedure)))))))))
+
+(define-syntax method*
+  (lambda (x)
+    (syntax-case x ()
+      ((_ formals) #'(method formals (if #f #f)))
+      ((_ formals body0 body1 ...)
+       (with-syntax (((formals (specializer ...) keyword-formals)
+                      (parse-keyword-formals #'formals)))
+         (call-with-values
+             (lambda ()
+               (compute-procedures #'formals
+                                   #'keyword-formals
+                                   #'(body0 body1 ...)))
+           (lambda (procedure make-procedure)
+             (with-syntax ((procedure procedure)
+                           (make-procedure make-procedure))
+               #`(make <method>
+                   #:specializers (cons* specializer ...)
                    #:formals (if (null? 'keyword-formals)
                                  'formals ;might be improper
                                  (append 'formals 'keyword-formals))



reply via email to

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