From d619da8c351d80ba153e71aaf51d8d2f9c3584e7 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 24 Nov 2024 14:54:20 +0100 Subject: [PATCH] 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 . (parse-formals): Re-introduce the code of previous parse-args. (%compute-applicable-methods): Revert change of previous commit. Giving keyword methods a specializer tail 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 | 121 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 108 insertions(+), 13 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. @@ -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 #: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 ))) + (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 #: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 #' specializers)) ;to be cons*:ed (cons #'f #'rest))) - (() (list (reverse formals) (reverse (cons #''() specializers)) @@ -2116,6 +2164,27 @@ function." (reverse (cons #' 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 #' specializers))) + (() + (list (reverse formals) + (reverse (cons #''() specializers)))) + (tail + (identifier? #'tail) + (list (append (reverse formals) #'tail) + (reverse (cons #' specializers))))))) + (define (find-free-id exp referent) (syntax-case exp () ((x . y) @@ -2218,12 +2287,40 @@ 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 ...)) + (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 + #:specializers (cons* specializer ...) ;yes, this + ;; 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-formals #'formals))) + (parse-keyword-formals #'formals))) (call-with-values (lambda () (compute-procedures #'formals @@ -2233,9 +2330,7 @@ function." (with-syntax ((procedure procedure) (make-procedure make-procedure)) #`(make - #:specializers (cons* specializer ...) ;yes, this - ;; The cons* is needed to get at the value of each - ;; specializer. + #:specializers (cons* specializer ...) #:formals (if (null? 'keyword-formals) 'formals ;might be improper (append 'formals 'keyword-formals))