diff --git a/doc/guix-cookbook.texi b/doc/guix-cookbook.texi index 4b6f0ca22c..83bce66c17 100644 --- a/doc/guix-cookbook.texi +++ b/doc/guix-cookbook.texi @@ -5297,7 +5297,7 @@ did above with transformation options. We can add them like so: "Return P with FLAGS as additional 'configure' flags." (package/inherit p (arguments - (substitute-keyword-arguments (package-arguments p) + (substitute-keyword-arguments arguments ((#:configure-flags original-flags #~(list)) #~(append #$original-flags #$flags)))))) diff --git a/doc/guix.texi b/doc/guix.texi index e7bcd174a8..d5f782f35c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8800,14 +8800,15 @@ dependency like so: (define gdb-sans-guile (package (inherit gdb) - (inputs (modify-inputs (package-inputs gdb) + (inputs (modify-inputs inputs (delete "guile"))))) @end lisp -The @code{modify-inputs} form above removes the @code{"guile"} package -from the @code{inputs} field of @code{gdb}. The @code{modify-inputs} -macro is a helper that can prove useful anytime you want to remove, add, -or replace package inputs. +In the body of the @code{inputs} field above, @code{inputs} is bound to +the inherited value. Thus, the @code{modify-inputs} form above removes +the @code{"guile"} package from the @code{inputs} field of @code{gdb}. +The @code{modify-inputs} macro is a helper that can prove useful anytime +you want to remove, add, or replace package inputs. @defmac modify-inputs inputs clauses Modify the given package inputs, as returned by @code{package-inputs} & co., @@ -9131,7 +9132,7 @@ these lines: (define gdb-sans-guile (package (inherit gdb) - (inputs (modify-inputs (package-inputs gdb) + (inputs (modify-inputs inputs (delete "guile"))))) ;; Return a manifest containing that one package plus Git. diff --git a/guix/records.scm b/guix/records.scm index 261f6f07b6..bf746d3b5d 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2025 Ludovic Courtès +;;; Copyright © 2012-2026 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -192,18 +192,55 @@ of TYPE matches the expansion-time ABI." (or (and=> (assoc-ref lst (syntax->datum f)) car) #'(lambda (x) x))))) - (define (wrap-field-value f value) + (define (field-index f) + ;; Return the index of F within the record. + (let ((f (syntax->datum f))) + (let loop ((fields '(expected ...)) + (index 0)) + (match fields + (() + ;; Internal error. + (record-error 'name s "field not found ~a" f)) + ((head . rest) + (if (eq? f head) + index + (loop rest (+ 1 index)))))))) + + (define* (wrap-field-value f value #:optional parent) + ;; Wrap VALUE, the value of field F, such that its sanitizer is + ;; called and its properties (thunked, delayed) honored. When + ;; PARENT is true, bind F to the value inherited from PARENT in the + ;; lexical scope of VALUE. (let* ((sanitizer (field-sanitizer f)) (value #`(#,sanitizer #,value))) (cond ((thunked-field? f) - #`(lambda (x) - (syntax-parameterize ((#,this-identifier - (lambda (s) - (syntax-case s () - (id - (identifier? #'id) - #'x))))) - #,value))) + (if parent + ;; Compute the value being inherited by calling the + ;; thunked field F of PARENT with a self-reference for + ;; the new record being constructed. + (with-syntax ((inherited + #`((struct-ref #,parent + #,(field-index f)) + #,this-identifier))) + #`(lambda (x) + (syntax-parameterize ((#,this-identifier + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + ;; Bind F, the field identifier, to the value + ;; being inherited. + (let-syntax ((#,f (identifier-syntax inherited))) + #,value)))) + #`(lambda (x) + (syntax-parameterize ((#,this-identifier + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value)))) ((delayed-field? f) #`(delay #,value)) (else value)))) @@ -227,9 +264,19 @@ of TYPE matches the expansion-time ABI." #,(wrap-field-value #'field #'value))))) field+value)) + (define (field-bindings/inheritance parent field+value) + ;; Return field to value bindings, for use in 'let*' below. + (map (lambda (field+value) + (syntax-case field+value () + ((field value) + #`(field + #,(wrap-field-value #'field #'value parent))))) + field+value)) + (syntax-case s (inherit expected ...) ((_ (inherit orig-record) (field value) (... ...)) - #`(let* #,(field-bindings #'((field value) (... ...))) + #`(let* #,(field-bindings/inheritance #'orig-record + #'((field value) (... ...))) #,(abi-check #'type abi-cookie) #,(record-inheritance #'orig-record #'((field value) (... ...))))) diff --git a/tests/records.scm b/tests/records.scm index 5464892d3b..9c071334d5 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2016, 2018-2022 Ludovic Courtès +;;; Copyright © 2012-2016, 2018-2022, 2026 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -238,6 +238,70 @@ (bar? first) (eq? first y))))))) +(test-equal "define-record-type* & thunked & no inherited value" + '(baz) ;the unbound variable + (catch 'unbound-variable + (lambda () + (eval '(begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + ;; There's no inheritance here so 'baz' is unbound in the field + ;; body. Call 'foo-baz' to trigger to unbound variable error. + (foo-baz (foo (bar 1) (baz baz)))) + (test-module))) + (lambda (key proc message arguments . rest) + arguments))) + +(test-equal "define-record-type* & thunked & inherited value" + '(1 22) + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + (let* ((parent (foo (bar 1) (baz 2))) + (child (foo (inherit parent) + (baz (* baz 11))))) + (list (foo-bar child) (foo-baz child))))) + +(test-equal "define-record-type* & thunked & inherited value & this-record" + '((1 2) => (21 (inherited . 42))) + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + (let* ((parent (foo (bar 1) + (baz (* 2 (foo-bar this-record))))) + (child (foo (inherit parent) + (bar 21) + (baz (cons 'inherited baz))))) + `((,(foo-bar parent) ,(foo-baz parent)) + => + (,(foo-bar child) ,(foo-baz child)))))) + +(test-equal "define-record-type* & thunked & inherited value & sanitizer" + '((1 "2") => (4 "88")) + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) (sanitize number->string))) + + (let* ((parent (foo (bar 1) + (baz (* 2 (foo-bar this-record))))) + (child (foo (inherit parent) + (bar 4) + (baz (+ 80 (string->number baz)))))) + `((,(foo-bar parent) ,(foo-baz parent)) + => + (,(foo-bar child) ,(foo-baz child)))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo