From patchwork Fri Mar 22 17:27:17 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 1528 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id EA84016DA2; Fri, 22 Mar 2019 17:44:56 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 9139616D88 for ; Fri, 22 Mar 2019 17:44:56 +0000 (GMT) Received: from localhost ([127.0.0.1]:60818 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7ODv-0006n4-Pj for patchwork@mira.cbaines.net; Fri, 22 Mar 2019 13:44:55 -0400 Received: from eggs.gnu.org ([209.51.188.92]:58998) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7OBJ-0004Nl-PN for guix-patches@gnu.org; Fri, 22 Mar 2019 13:42:16 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h7Nxa-0005tR-Vq for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:41107) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h7Nxa-0005rl-OK for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1h7Nxa-0001Zg-Cu for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. References: <20190322172120.10974-1-ludo@gnu.org> In-Reply-To: <20190322172120.10974-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 22 Mar 2019 17:28:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 34948 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34948@debbugs.gnu.org Received: via spool by 34948-submit@debbugs.gnu.org id=B34948.15532756596001 (code B ref 34948); Fri, 22 Mar 2019 17:28:02 +0000 Received: (at 34948) by debbugs.gnu.org; 22 Mar 2019 17:27:39 +0000 Received: from localhost ([127.0.0.1]:54647 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxC-0001Yh-AD for submit@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:38 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42616) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxA-0001YO-Hr for 34948@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:36 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46963) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7Nx4-0004is-F1; Fri, 22 Mar 2019 13:27:30 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=49252 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1h7Nx3-0001o0-Qc; Fri, 22 Mar 2019 13:27:30 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 22 Mar 2019 18:27:17 +0100 Message-Id: <20190322172719.11199-1-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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. --- guix/records.scm | 24 ++++++++++++++++++++++-- tests/records.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 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 diff --git a/tests/records.scm b/tests/records.scm index d9469a78bd..45614093a0 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -170,6 +170,46 @@ (parameterize ((mark (cons 'a 'b))) (eq? (foo-bar y) (mark))))))) +(test-assert "define-record-type* & thunked & this-record" + (begin + (define-record-type* 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 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 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 make-foo