#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:export (define-record-type*
+ this-record
+
alist->record
object->fields
recutils->alist
(()
#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
(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)))
(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
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-bar y) (mark)))))))
+(test-assert "define-record-type* & thunked & this-record"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)))
+
+ (let ((x (foo (bar 40)
+ (baz (+ (foo-bar this-record) 2)))))
+ (and (= 40 (foo-bar x))
+ (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & default & this-record"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)
+ (default (+ (foo-bar this-record) 2))))
+
+ (let ((x (foo (bar 40))))
+ (and (= 40 (foo-bar x))
+ (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & inherit & this-record"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)
+ (default (+ (foo-bar this-record) 2))))
+
+ (let* ((x (foo (bar 40)))
+ (y (foo (inherit x) (bar -2)))
+ (z (foo (inherit x) (baz -2))))
+ (and (= -2 (foo-bar y))
+ (= 0 (foo-baz y))
+ (= 40 (foo-bar z))
+ (= -2 (foo-baz z))))))
+
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo