diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2019-03-22 14:02:00 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2019-03-25 23:37:06 +0100 |
| commit | abd4d6b33dba4de228e90ad15a8efb456fcf7b6e (patch) | |
| tree | 82851cffc3953f138df72fee42a2f5d801dde005 /guix | |
| parent | 3191b5f6ba5ebbb59a7448facd999ad7f7aeae79 (diff) | |
records: Allow thunked fields to refer to 'this-record'.
* guix/records.scm (this-record): New syntax parameter.
(make-syntactic-constructor)[wrap-field-value]: When F is thunked,
return a one-argument lambda instead of a thunk, and parameterize
THIS-RECORD.
(define-record-type*)[thunked-field-accessor-definition]: Pass X
to (real-get X).
* tests/records.scm ("define-record-type* & thunked & this-record")
("define-record-type* & thunked & default & this-record")
("define-record-type* & thunked & inherit & this-record"): New tests.
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/records.scm | 24 |
1 files changed, 22 insertions, 2 deletions
diff --git a/guix/records.scm b/guix/records.scm index 0649c90ea3..244b124098 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -25,6 +25,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:export (define-record-type* + this-record + alist->record object->fields recutils->alist @@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE." (() #t))))))) +(define-syntax-parameter this-record + (lambda (s) + "Return the record being defined. This macro may only be used in the +context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-record + "cannot be used outside of a record instantiation" + #'id))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -148,7 +161,14 @@ of TYPE matches the expansion-time ABI." (define (wrap-field-value f value) (cond ((thunked-field? f) - #`(lambda () #,value)) + #`(lambda (x) + (syntax-parameterize ((this-record + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value))) ((delayed-field? f) #`(delay #,value)) (else value))) @@ -308,7 +328,7 @@ inherited." (with-syntax ((real-get (wrapped-field-accessor-name field))) #'(define-inlinable (get x) ;; The real value of that field is a thunk, so call it. - ((real-get x))))))) + ((real-get x) x)))))) (define (delayed-field-accessor-definition field) ;; Return the real accessor for FIELD, which is assumed to be a |