summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <mikael@djurfeldt.com>2024-11-25 11:17:41 +0100
committerMikael Djurfeldt <mikael@djurfeldt.com>2024-11-25 21:47:53 +0100
commitf057e02d9a9cfd98a4e8e18d0d045283647e8f2c (patch)
tree43ff0c2170f9b8a887fdfba491ce4018e85ff5ab
parent2d18afe5accef402ceb477ac585a46871570dd23 (diff)
downloadguile-f057e02d9a9cfd98a4e8e18d0d045283647e8f2c.tar.gz
Correctly pass on keyword arguments actually present in args list
* module/oop/goops.scm (compute-keyword-formal-ids): Renamed from ->keyword-formal-ids; modified to do work both on the list of formals and the list of formal ids in the next-method call. (compute-make-procedure): Use compute-keyword-formal-ids.
-rw-r--r--module/oop/goops.scm81
1 files changed, 58 insertions, 23 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 5ef39d17f..12644eba5 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -2221,30 +2221,72 @@ function."
(() (cons (reverse out) '()))
(tail (cons (reverse out) #'tail)))))
- ;; keyword-formal-ids KEYWORD-FORMALS
+ ;; compute-keyword-formal-ids FORMALS 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 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.
;;
- ;; The output is used in the next-method application form.
+ ;; FORMALS is the non-keyword part of the formal arguments.
+ ;; KEYWORD-FORMALS is the part of the formal arguments from the
+ ;; first keyword.
;;
- (define (->keyword-formal-ids keyword-formals)
- (let lp ((ls keyword-formals) (out '()))
+ ;; 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 ()
- (((f val) . rest)
- (lp #'rest out))
((#:rest f)
- (cons (reverse out) #'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)
- (keyword? (syntax->datum #'f))
- (lp #'rest out))
+ (lp-key #'rest
+ (cons #'f formals) ;keep
+ formal-ids)) ;filter away
+ (tail
+ (result (append (reverse formals) #'tail)
+ (cons (reverse formal-ids) #'tail)))))
+
+ (let ((reversed-formals (reverse formals)))
+ (let lp ((ls keyword-formals)
+ (formals reversed-formals)
+ (formal-ids reversed-formals))
+ (syntax-case ls ()
+ (((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 out)))
+ (lp #'rest (cons #'f formals) (cons #'f formal-ids)))
(()
- (cons (reverse out) '()))
+ (result (reverse formals) (cons (reverse formal-ids) '())))
(tail
- (cons (reverse out) #'tail)))))
+ (result (append (reverse formals) #'tail)
+ (cons (reverse formal-ids) #'tail)))))))
(define (compute-make-procedure formals keyword-formals body next-method)
(syntax-case body ()
@@ -2255,14 +2297,7 @@ function."
(values #'lambda
formals
(->formal-ids formals))
- (values #'lambda*
- (append formals keyword-formals)
- (let ((keyword-formal-ids
- ;; filter out the identifiers
- (->keyword-formal-ids keyword-formals)))
- ;; input and result in formals-ids format
- (cons (append formals (car keyword-formal-ids))
- (cdr keyword-formal-ids))))))
+ (compute-keyword-formal-ids formals keyword-formals)))
(lambda (lambda-type formals formal-ids)
(with-syntax ((next-method next-method))
(syntax-case formals ()