Keywords in GOOPS methods v2

Keywords in GOOPS methods v2

[Mikael Djurfeldt]

[-- Attachment #1.1: Type: text/plain, Size: 896 bytes --]

This is my second attempt at introducing keyword aware methods in GOOPS.

I was split but finally decided to go with keeping keyword non-aware
define-method and method and introducing keyword aware new syntax method*
and define-method*. Arguments are:

1. It preserves simplicity in method and define-method such that other
implementations (like guile-hoot) can choose to only define these (and
possibly provide something like Mark's macro doe define-method*).
2. It aligns with lambda* and define*.
3. It is somewhat better at protecting backward compatibility.
4. It preserves the option to also in the internal implementation use
something like Mark's macro once this gives equal performance.

I've also committed these changes to

https://github.com/mdjurfeldt/guile/tree/goops-keyword

I'm going to start documenting this now and will then commit it to the
Guile repo.

Best regards,
Mikael

[-- Attachment #1.2: Type: text/html, Size: 1221 bytes --]

[-- Attachment #2: goops-kw-patch-2.patch --]
[-- Type: text/x-patch, Size: 13840 bytes --]

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 8ed68694c..01bf1612e 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>
@@ -2024,8 +2025,7 @@ function."
            (else
             (and (memq (car specs) (class-precedence-list (car types)))
                  (lp (cdr specs) (cdr types))))))))))
-  (let ((n (length args))
-        (types (map class-of args)))
+  (let ((types (map class-of args)))
     (let lp ((methods (generic-function-methods gf))
              (applicable '()))
       (if (null? methods)
@@ -2042,6 +2042,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 ...)
@@ -2064,10 +2094,76 @@ function."
          (toplevel-define! 'name (make <generic> #:name 'name)))
        (add-method! name (method args body ...))))))
 
-(define-syntax method
-  (lambda (x)
-    (define (parse-args args)
-      (let lp ((ls args) (formals '()) (specializers '()))
+(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)
+    ;;
+    ;; FORMALS is the possibly improper list of specializable formals.
+    ;;
+    ;; SPECIALIZERS is a proper list of the corresponding specializers.
+    ;; Its last element corresponds to the cdr of the last element in
+    ;; METHOD-FORMALS such that the possibly improper list corresponding
+    ;; to FORMALS can be obtained by applying cons* to SPECIALIZERS.
+    ;; The reason for handling it like this is that the specializers are
+    ;; each evaluated to their values and therefore *must* be provided
+    ;; by a cons* in the (make <method> ...) expression.
+    ;;
+    ;; KEYWORD_FORMALS is the part of METHOD-FORMALS which starts with a
+    ;; keyword and corresponds to the keyword-syntax of lambda*. These
+    ;; are not specializable (which also corresponds to CLOS
+    ;; functionality).
+    ;;
+    (define (parse-keyword-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)))
+          ((f . rest)
+           (keyword? (syntax->datum #'f))
+           (list (reverse formals)
+                 (reverse (cons #'<top> specializers)) ;to be cons*:ed
+                 (cons #'f #'rest)))
+          (()
+           (list (reverse formals)
+                 (reverse (cons #''() specializers))
+                 '()))                  ;yes, not #''(); used in tests
+          (tail
+           (identifier? #'tail)
+           (list (append (reverse formals) #'tail)
+                 (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))
@@ -2098,43 +2194,87 @@ function."
            (and (free-identifier=? #'x id) id)))
         (_ #f)))
 
-    (define (compute-procedure formals body)
+    (define (compute-procedure formals keyword-formals body)
       (syntax-case body ()
         ((body0 ...)
-         (with-syntax ((formals formals))
-           #'(lambda formals body0 ...)))))
-
-    (define (->proper args)
-      (let lp ((ls args) (out '()))
+         (let ((formals (if (null? keyword-formals)
+                            formals
+                            (append formals keyword-formals))))
+           (with-syntax ((formals formals))
+             #`(lambda* formals body0 ...))))))
+
+    ;; ->formal-ids FORMALS
+    ;;
+    ;; convert FORMALS into formal-ids format, which is a cell where the
+    ;; car is the list of car:s in FORMALS and the cdr is the cdr of the
+    ;; last cell in FORMALS.
+    ;;
+    ;; The motivation for this format is to determine at low cost if
+    ;; FORMALS is improper or not and to easily be able to generate the
+    ;; corresponding next-method call.
+    ;;
+    (define (->formal-ids formals)
+      (let lp ((ls formals) (out '()))
         (syntax-case ls ()
-          ((x . xs)        (lp #'xs (cons #'x out)))
-          (()              (reverse out))
-          (tail            (reverse (cons #'tail out))))))
+          ((x . xs) (lp #'xs (cons #'x out)))
+          (()       (cons (reverse out) '()))
+          (tail     (cons (reverse out) #'tail)))))
+
+    ;; keyword-formal-ids KEYWORD-FORMALS
+    ;;
+    ;; return a form corresponding to KEYWORD-FORMALS but with
+    ;; identifiers only (keywords removed) The value returned has the
+    ;; formals-ids format as described above.
+    ;;
+    ;; The output is used in the next-method application form.
+    ;;
+    (define (->keyword-formal-ids keyword-formals)
+      (let lp ((ls keyword-formals) (out '()))
+        (syntax-case ls ()
+          (((f val) . rest)
+           (lp #'rest out))
+          ((#:rest f)
+           (cons (reverse out) #'f))
+          ((f . rest)
+           (keyword? (syntax->datum #'f))
+           (lp #'rest out))
+          ((f . rest)
+           (lp #'rest (cons #'f out)))
+          (()
+           (cons (reverse out) '()))
+          (tail
+           (cons (reverse out) #'tail)))))
 
-    (define (compute-make-procedure formals body next-method)
+    (define (compute-make-procedure formals keyword-formals body next-method)
       (syntax-case body ()
         ((body ...)
-         (with-syntax ((next-method next-method))
-           (syntax-case formals ()
-             ((formal ...)
-              #'(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 #'formals)))
-                #'(lambda (real-next-method)
-                    (lambda formals
-                      (let ((next-method (lambda args
-                                           (if (null? args)
-                                               (apply real-next-method formal ...)
-                                               (apply real-next-method args)))))
+         (let ((formals (if (null? keyword-formals)
+                            formals     ;might be improper
+                            (append formals keyword-formals)))
+               (formal-ids
+                (if (null? keyword-formals)
+                    (->formal-ids formals)
+                    (let ((kw-formal-ids (->keyword-formal-ids keyword-formals)))
+                      ;; input and result in formals-ids format
+                      (cons (append formals (car kw-formal-ids))
+                            (cdr kw-formal-ids))))))
+           (with-syntax ((next-method next-method))
+             (syntax-case formals ()
+               (formals
+                #`(lambda (real-next-method)
+                    (lambda* formals
+                      (let ((next-method
+                             (lambda args
+                               (if (null? args)
+                                   #,(if (null? (cdr formal-ids))
+                                         #`(real-next-method #,@(car formal-ids))
+                                         #`(apply real-next-method
+                                                  #,@(car formal-ids)
+                                                  #,(cdr formal-ids)))
+                                   (apply real-next-method args)))))
                         body ...))))))))))
 
-    (define (compute-procedures formals body)
+    (define (compute-procedures formals keyword-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.
@@ -2142,23 +2282,55 @@ function."
         (if id
             ;; return a make-procedure
             (values #'#f
-                    (compute-make-procedure formals body id))
-            (values (compute-procedure formals body)
+                    (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 ...))
+                      (parse-formals #'formals)))
+         (call-with-values
+             (lambda ()
+               (compute-procedures #'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 the value of each
+                   ;; specializer.
+                   #:formals 'formals ;might be improper
+                   #:body '(body0 body1 ...)
+                   #:make-procedure make-procedure
+                   #:procedure procedure)))))))))
 
+(define-syntax method*
+  (lambda (x)
     (syntax-case x ()
-      ((_ args) #'(method args (if #f #f)))
-      ((_ args body0 body1 ...)
-       (with-syntax (((formals (specializer ...)) (parse-args #'args)))
+      ((_ 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 #'(body0 body1 ...)))
+               (compute-procedures #'formals
+                                   #'keyword-formals
+                                   #'(body0 body1 ...)))
            (lambda (procedure make-procedure)
              (with-syntax ((procedure procedure)
                            (make-procedure make-procedure))
-               #'(make <method>
+               #`(make <method>
                    #:specializers (cons* specializer ...)
-                   #:formals 'formals
+                   #:formals (if (null? 'keyword-formals)
+                                 'formals ;might be improper
+                                 (append 'formals 'keyword-formals))
                    #:body '(body0 body1 ...)
                    #:make-procedure make-procedure
                    #:procedure procedure)))))))))

Re: Keywords in GOOPS methods v2

[Mikael Djurfeldt]

Guile maintainers might want to consider if we should time this kind of
change in the API with a particular release. For my part, I think we could
just add it.

On Sun, Nov 24, 2024 at 3:40 PM Mikael Djurfeldt <mikael@djurfeldt.com>
wrote:

> This is my second attempt at introducing keyword aware methods in GOOPS.
>
> I was split but finally decided to go with keeping keyword non-aware
> define-method and method and introducing keyword aware new syntax method*
> and define-method*. Arguments are:
>
> 1. It preserves simplicity in method and define-method such that other
> implementations (like guile-hoot) can choose to only define these (and
> possibly provide something like Mark's macro doe define-method*).
> 2. It aligns with lambda* and define*.
> 3. It is somewhat better at protecting backward compatibility.
> 4. It preserves the option to also in the internal implementation use
> something like Mark's macro once this gives equal performance.
>
> I've also committed these changes to
>
> https://github.com/mdjurfeldt/guile/tree/goops-keyword
>
> I'm going to start documenting this now and will then commit it to the
> Guile repo.
>
> Best regards,
> Mikael
>
>

Re: Keywords in GOOPS methods v2

[Mikael Djurfeldt]

[-- Attachment #1: Type: text/plain, Size: 1524 bytes --]

Ah... I forgot to complete parse-keyword-formals, which is currently only
rudimentary and doesn't compose the correct argument list for (next-method).

There will be a version 3...

On Sun, Nov 24, 2024 at 3:43 PM Mikael Djurfeldt <mikael@djurfeldt.com>
wrote:

> Guile maintainers might want to consider if we should time this kind of
> change in the API with a particular release. For my part, I think we could
> just add it.
>
> On Sun, Nov 24, 2024 at 3:40 PM Mikael Djurfeldt <mikael@djurfeldt.com>
> wrote:
>
>> This is my second attempt at introducing keyword aware methods in GOOPS.
>>
>> I was split but finally decided to go with keeping keyword non-aware
>> define-method and method and introducing keyword aware new syntax method*
>> and define-method*. Arguments are:
>>
>> 1. It preserves simplicity in method and define-method such that other
>> implementations (like guile-hoot) can choose to only define these (and
>> possibly provide something like Mark's macro doe define-method*).
>> 2. It aligns with lambda* and define*.
>> 3. It is somewhat better at protecting backward compatibility.
>> 4. It preserves the option to also in the internal implementation use
>> something like Mark's macro once this gives equal performance.
>>
>> I've also committed these changes to
>>
>> https://github.com/mdjurfeldt/guile/tree/goops-keyword
>>
>> I'm going to start documenting this now and will then commit it to the
>> Guile repo.
>>
>> Best regards,
>> Mikael
>>
>>

[-- Attachment #2: Type: text/html, Size: 2371 bytes --]

Re: Keywords in GOOPS methods v2

[David Pirotte]

[-- Attachment #1: Type: text/plain, Size: 425 bytes --]

Hi Mikael,

> Guile maintainers might want to consider if we should time this kind
> of change in the API with a particular release. For my part, I think
> we could just add it.

1+
imo as well, there is no need to wait for a particular release [*]

David

[*] especially since you said in another email that you plan to add
method* and define-method* and leave the existing method and
define-method unchanged.

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]