[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))
- [Guile-commits] branch main updated (c51fcfffb -> a3c77cb8d), Mikael Djurfeldt, 2024/11/25
- [Guile-commits] 02/07: GOOPS: Introduce new forms method* and define-method*,
Mikael Djurfeldt <=
- [Guile-commits] 03/07: Remove method slot keyword-formals? introduced in 765f1d49, Mikael Djurfeldt, 2024/11/25
- [Guile-commits] 04/07: Distinguish between lambda and lambda* in generated procedures, Mikael Djurfeldt, 2024/11/25
- [Guile-commits] 05/07: Correctly pass on keyword arguments actually present in args list, Mikael Djurfeldt, 2024/11/25
- [Guile-commits] 06/07: Document method* and define-method*, Mikael Djurfeldt, 2024/11/25
- [Guile-commits] 01/07: GOOPS: Add support for keyword arguments in methods, Mikael Djurfeldt, 2024/11/25
- [Guile-commits] 07/07: Update NEWS, Mikael Djurfeldt, 2024/11/25