Keywords in GOOPS methods v3

[Mikael Djurfeldt <mikael@djurfeldt.com>]

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

This is the third attempt at introducing keyword aware methods in GOOPS.

What is new in v3 is that keyword arguments and default parameters to
keyword arguments are handled correctly when using (next-method). Now only
those keyword arguments actually present in a call get forwarded to the
next-method.

I've also committed these changes to

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

Best regards,
Mikael

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

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 8ed68694c..12644eba5 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,135 @@ 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 ...)))))
+         (if (null? keyword-formals)
+             (with-syntax ((formals formals))
+               #'(lambda formals body0 ...))
+             (let ((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, i.e. the final tail.
+    ;;
+    ;; The motivation for this format is to easily determine if FORMALS
+    ;; is improper or not in order 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)))
+          (()       (cons (reverse out) '()))
+          (tail     (cons (reverse out) #'tail)))))
+
+    ;; compute-keyword-formal-ids FORMALS KEYWORD-FORMALS
+    ;;
+    ;; The main purpose of this beast is to compute the argument list
+    ;; for the actual next-method call for the case where the user calls
+    ;; (next-method). It is invoked in the case where we have keyword
+    ;; formals. Here we have to treat keyword arguments in a special way
+    ;; since we, similar to CLOS, only want to pass on the keyword
+    ;; arguments that were present in the call. We capture those using
+    ;; the rest argument. If not present, we introduce a rest formal.
+    ;;
+    ;; FORMALS is the non-keyword part of the formal arguments.
+    ;; KEYWORD-FORMALS is the part of the formal arguments from the
+    ;; first keyword.
+    ;;
+    ;; return three values:
+    ;;
+    ;; 1. #'lambda
+    ;; 2. the complete formals list
+    ;; 3. the argument list for next-method in formals-ids format as
+    ;;    described above (proper list in CAR, tail in CDR)
+    ;;
+    (define (compute-keyword-formal-ids formals keyword-formals)
+      (define (result formals formal-ids)
+        (values #'lambda* formals formal-ids))
+
+      (define (lp-key ls formals formal-ids)
+        (syntax-case ls ()
+          ((#:rest f)
+           (identifier? #'f)
+           (result (append (reverse formals) #'f)
+                   (cons (reverse formal-ids) #'f)))
+          (()
+           ;; No rest formal is present, so we need to introduce one.
+           (let ((rest-formal (car (generate-temporaries '(rest)))))
+             (result (append (reverse formals) rest-formal)
+                     (cons (reverse formal-ids) rest-formal))))
+          ((f . rest)
+           (lp-key #'rest
+                   (cons #'f formals)   ;keep
+                   formal-ids))         ;filter away
+          (tail
+           (result (append (reverse formals) #'tail)
+                   (cons (reverse formal-ids) #'tail)))))
 
-    (define (->proper args)
-      (let lp ((ls args) (out '()))
+      (let ((reversed-formals (reverse formals)))
+        (let lp ((ls keyword-formals)
+                 (formals reversed-formals)
+                 (formal-ids reversed-formals))
         (syntax-case ls ()
-          ((x . xs)        (lp #'xs (cons #'x out)))
-          (()              (reverse out))
-          (tail            (reverse (cons #'tail out))))))
+          (((f val) . rest)
+           (lp #'rest (cons #'(f val) formals) (cons #'f formal-ids)))
+          ((#:optional . rest)
+           (lp #'rest (cons #:optional formals) formal-ids))
+          ((#:key . rest)
+           (lp-key #'rest (cons #:key formals) formal-ids))
+          ((#:rest f)
+           (identifier? #'f)
+           (result (append (reverse formals) #'f)
+                   (cons (reverse formal-ids) #'f)))
+          ((f . rest)
+           (lp #'rest (cons #'f formals) (cons #'f formal-ids)))
+          (()
+           (result (reverse formals) (cons (reverse formal-ids) '())))
+          (tail
+           (result (append (reverse formals) #'tail)
+                   (cons (reverse formal-ids) #'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)))))
-                        body ...))))))))))
-
-    (define (compute-procedures formals body)
+         (call-with-values
+             (lambda ()
+               (if (null? keyword-formals)
+                   (values #'lambda
+                           formals
+                           (->formal-ids formals))
+                   (compute-keyword-formal-ids formals keyword-formals)))
+           (lambda (lambda-type formals formal-ids)
+             (with-syntax ((next-method next-method))
+               (syntax-case formals ()
+                 (formals
+                  #`(lambda (real-next-method)
+                      (#,lambda-type    ;lambda or lambda*
+                       formals
+                       (let ((next-method
+                              (lambda args
+                                (if (null? args)
+                                    ;; We have (next-method) and need to
+                                    ;; pass on the arguments to the method.
+                                    #,(if (null? (cdr formal-ids))
+                                          ;; proper list of identifiers
+                                          #`(real-next-method
+                                             #,@(car formal-ids))
+                                          ;; last identifier is a rest list
+                                          #`(apply real-next-method
+                                                   #,@(car formal-ids)
+                                                   #,(cdr formal-ids)))
+                                    ;; user passes arguments to next-method
+                                    (apply real-next-method args)))))
+                         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 +2330,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)))))))))