mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

GOOPS: Add support for keyword arguments in methods

Browse source 
* module/oop/goops.scm (keyword-formals?): New slot in <method>.
  (method-keyword-formals?): New exported <method> getter.
  (%compute-applicable-methods): Treat method as applicable if having
  matched all specializers, still have further arguments and have
  keyword-formals.
  (%compute-applicable-methods): Remove unused local variable n.
  (define-syntax method): Rename parse-args to parse-formals.
  (parse-formals): Return formals, specializers and keyword-formals.
  (compute-procedure): Make a lambda* with possibly keyword formals.
  (->formal-ids): Renamed from ->proper and now returns formal-ids.
  (->keyword-formal-ids): New procedure. Filter out formal ids from
  a keyword formal specification.
  (compute-make-procedure): Adapted for keyword formals. Needs
  ->formal-ids and ->keyword-formal-ids to compute the
  real-next-method call.
  (compute-procedures): Pass on keyword-formals.
  (syntax method): Adapted for keyword formals.
This commit is contained in:
Mikael Djurfeldt 2024-11-19 17:23:06 +01:00
parent c51fcfffb6
commit be2f965f85
1 changed files with 130 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

175
module/oop/goops.scm
View file

@ -135,7 +135,7 @@
class-slots class-slots
generic-function-name generic-function-name
generic-function-methods method-generic-function generic-function-methods method-generic-function
method-specializers method-formals method-specializers method-formals method-keyword-formals?
primitive-generic-generic enable-primitive-generic! primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition method-procedure accessor-method-slot-definition
make find-method get-keyword)) make find-method get-keyword))
@ -1052,6 +1052,7 @@ slots as we go."
specializers specializers
procedure procedure
formals formals
keyword-formals?
body body
make-procedure) make-procedure)
(define-standard-class <accessor-method> (<method>) (define-standard-class <accessor-method> (<method>)
@ -1156,6 +1157,7 @@ function."
(#:specializers specializers ()) (#:specializers specializers ())
(#:procedure procedure #f) (#:procedure procedure #f)
(#:formals formals ()) (#:formals formals ())
(#:keyword-formals? keyword-formals? #f)
(#:body body ()) (#:body body ())
(#:make-procedure make-procedure #f)))) (#:make-procedure make-procedure #f))))
((memq <class> (class-precedence-list class)) ((memq <class> (class-precedence-list class))
@ -2018,14 +2020,14 @@ function."
(else (else
(let lp ((specs specs) (types types)) (let lp ((specs specs) (types types))
(cond (cond
((null? specs) (null? types)) ((null? specs)
(or (null? types) (method-keyword-formals? m)))
((not (pair? specs)) #t) ((not (pair? specs)) #t)
((null? types) #f) ((null? types) #f)
(else (else
(and (memq (car specs) (class-precedence-list (car types))) (and (memq (car specs) (class-precedence-list (car types)))
(lp (cdr specs) (cdr types)))))))))) (lp (cdr specs) (cdr types))))))))))
(let ((n (length args)) (let ((types (map class-of args)))
(types (map class-of args)))
(let lp ((methods (generic-function-methods gf)) (let lp ((methods (generic-function-methods gf))
(applicable '())) (applicable '()))
(if (null? methods) (if (null? methods)
@ -2066,8 +2068,27 @@ function."
(define-syntax method (define-syntax method
(lambda (x) (lambda (x)
(define (parse-args args) ;; parse-formals METHOD-FORMALS
(let lp ((ls args) (formals '()) (specializers '())) ;;
;; 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-formals method-formals)
(let lp ((ls method-formals) (formals '()) (specializers '()))
(syntax-case ls () (syntax-case ls ()
(((f s) . rest) (((f s) . rest)
(and (identifier? #'f) (identifier? #'s)) (and (identifier? #'f) (identifier? #'s))
@ -2079,13 +2100,21 @@ function."
(lp #'rest (lp #'rest
(cons #'f formals) (cons #'f formals)
(cons #'<top> specializers))) (cons #'<top> specializers)))
((f . rest)
(keyword? (syntax->datum #'f))
(list (reverse formals)
(reverse (cons #''() specializers)) ;to be cons*:ed
(cons #'f #'rest)))
(() (()
(list (reverse formals) (list (reverse formals)
(reverse (cons #''() specializers)))) (reverse (cons #''() specializers))
'())) ;yes, not #''(); used in tests
(tail (tail
(identifier? #'tail) (identifier? #'tail)
(list (append (reverse formals) #'tail) (list (append (reverse formals) #'tail)
(reverse (cons #'<top> specializers))))))) (reverse (cons #'<top> specializers))
'())))))
(define (find-free-id exp referent) (define (find-free-id exp referent)
(syntax-case exp () (syntax-case exp ()
@ -2098,43 +2127,87 @@ function."
(and (free-identifier=? #'x id) id))) (and (free-identifier=? #'x id) id)))
(_ #f))) (_ #f)))
(define (compute-procedure formals body) (define (compute-procedure formals keyword-formals body)
(syntax-case body () (syntax-case body ()
((body0 ...) ((body0 ...)
(with-syntax ((formals formals)) (let ((formals (if (null? keyword-formals)
#'(lambda formals body0 ...))))) formals
(append formals keyword-formals))))
(with-syntax ((formals formals))
#`(lambda* formals body0 ...))))))
(define (->proper args) ;; ->formal-ids FORMALS
(let lp ((ls args) (out '())) ;;
;; 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 () (syntax-case ls ()
((x . xs) (lp #'xs (cons #'x out))) ((x . xs) (lp #'xs (cons #'x out)))
(() (reverse out)) (() (cons (reverse out) '()))
(tail (reverse (cons #'tail out)))))) (tail (cons (reverse out) #'tail)))))
(define (compute-make-procedure formals body next-method) ;; 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 keyword-formals body next-method)
(syntax-case body () (syntax-case body ()
((body ...) ((body ...)
(with-syntax ((next-method next-method)) (let ((formals (if (null? keyword-formals)
(syntax-case formals () formals ;might be improper
((formal ...) (append formals keyword-formals)))
#'(lambda (real-next-method) (formal-ids
(lambda (formal ...) (if (null? keyword-formals)
(let ((next-method (lambda args (->formal-ids formals)
(if (null? args) (let ((kw-formal-ids (->keyword-formal-ids keyword-formals)))
(real-next-method formal ...) ;; input and result in formals-ids format
(apply real-next-method args))))) (cons (append formals (car kw-formal-ids))
body ...)))) (cdr kw-formal-ids))))))
(formals (with-syntax ((next-method next-method))
(with-syntax (((formal ...) (->proper #'formals))) (syntax-case formals ()
#'(lambda (real-next-method) (formals
(lambda formals #`(lambda (real-next-method)
(let ((next-method (lambda args (lambda* formals
(if (null? args) (let ((next-method
(apply real-next-method formal ...) (lambda args
(apply real-next-method 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 ...)))))))))) 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 ;; So, our use of this is broken, because it operates on the
;; pre-expansion source code. It's equivalent to just searching ;; pre-expansion source code. It's equivalent to just searching
;; for referent in the datums. Ah well. ;; for referent in the datums. Ah well.
@ -2142,23 +2215,31 @@ function."
(if id (if id
;; return a make-procedure ;; return a make-procedure
(values #'#f (values #'#f
(compute-make-procedure formals body id)) (compute-make-procedure formals keyword-formals body id))
(values (compute-procedure formals body) (values (compute-procedure formals keyword-formals body)
#'#f)))) #'#f))))
(syntax-case x () (syntax-case x ()
((_ args) #'(method args (if #f #f))) ((_ formals) #'(method formals (if #f #f)))
((_ args body0 body1 ...) ((_ formals body0 body1 ...)
(with-syntax (((formals (specializer ...)) (parse-args #'args))) (with-syntax (((formals (specializer ...) keyword-formals)
(parse-formals #'formals)))
(call-with-values (call-with-values
(lambda () (lambda ()
(compute-procedures #'formals #'(body0 body1 ...))) (compute-procedures #'formals
#'keyword-formals
#'(body0 body1 ...)))
(lambda (procedure make-procedure) (lambda (procedure make-procedure)
(with-syntax ((procedure procedure) (with-syntax ((procedure procedure)
(make-procedure make-procedure)) (make-procedure make-procedure))
#'(make <method> #`(make <method>
#:specializers (cons* specializer ...) #:specializers (cons* specializer ...) ;yes, this
#:formals 'formals ;; The cons* is needed to get at the value of each
;; specializer.
#:formals (if (null? 'keyword-formals)
'formals ;might be improper
(append 'formals 'keyword-formals))
#:keyword-formals? (not (null? 'keyword-formals))
#:body '(body0 body1 ...) #:body '(body0 body1 ...)
#:make-procedure make-procedure #:make-procedure make-procedure
#:procedure procedure))))))))) #:procedure procedure)))))))))
@ -2281,6 +2362,9 @@ function."
(define-method (method-formals (m <method>)) (define-method (method-formals (m <method>))
(slot-ref m 'formals)) (slot-ref m 'formals))
(define-method (method-keyword-formals? (m <method>))
(slot-ref m 'keyword-formals?))
;;; ;;;
;;; Slots ;;; Slots
;;; ;;;
@ -2834,6 +2918,7 @@ var{initargs}."
(slot-set! method 'procedure (slot-set! method 'procedure
(get-keyword #:procedure initargs #f)) (get-keyword #:procedure initargs #f))
(slot-set! method 'formals (get-keyword #:formals initargs '())) (slot-set! method 'formals (get-keyword #:formals initargs '()))
(slot-set! method 'keyword-formals? (get-keyword #:keyword-formals? initargs #f))
(slot-set! method 'body (get-keyword #:body initargs '())) (slot-set! method 'body (get-keyword #:body initargs '()))
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f))) (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))