[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] 01/02: records: Support keyword arguments in the constru
From: |
gnunet |
Subject: |
[gnunet-scheme] 01/02: records: Support keyword arguments in the constructor. |
Date: |
Sat, 04 Mar 2023 01:31:07 +0100 |
This is an automated email from the git hooks/post-receive script.
maxime-devos pushed a commit to branch master
in repository gnunet-scheme.
commit 2a263aabfdd3e0216fd91aaa62368d68dd71b175
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Mar 4 01:29:07 2023 +0100
records: Support keyword arguments in the constructor.
This will be used by the DHT code in the next commit.
* gnu/gnunet/utils/records.scm
(constructor-keyword-arguments*): New variable, used in generated
syntax.
(constructor-keyword-arguments*/different): Likewise.
---
gnu/gnunet/utils/records.scm | 61 ++++++++++++++++++++++++++++++++++++++------
1 file changed, 53 insertions(+), 8 deletions(-)
diff --git a/gnu/gnunet/utils/records.scm b/gnu/gnunet/utils/records.scm
index a3839ff..0935efb 100644
--- a/gnu/gnunet/utils/records.scm
+++ b/gnu/gnunet/utils/records.scm
@@ -19,19 +19,20 @@
(export define-record-type*)
;; keyword? cannot be used from (srfi srfi-88) because that sets
;; a reader option.
- (import (only (guile) define* keyword? error define-values pk syntax-error)
+ (import (only (guile) define* lambda* keyword? error define-values pk
syntax-error)
(only (ice-9 match) match)
(only (rnrs base)
begin define lambda define-syntax cons quasiquote quote unquote
unquote-splicing apply reverse append null? eq? and not if
string? values map assert car cdr cadr cddr let or pair?
- => let*)
+ => let* length)
(only (rnrs control) when unless)
(only (rnrs syntax-case)
syntax quasisyntax unsyntax unsyntax-splicing syntax-case
- syntax->datum identifier? generate-temporaries datum->syntax)
+ syntax->datum identifier? generate-temporaries datum->syntax
+ free-identifier=?)
(only (rnrs records syntactic) define-record-type)
- (only (srfi srfi-1) assoc)
+ (only (srfi srfi-1) assoc partition)
;; in generated code
(only (rnrs base) =)
(only (gnu gnunet netstruct syntactic)
@@ -45,6 +46,7 @@
(define* (process fields^ <type> type?
#:key
+ (constructor-keyword-arguments unset)
(constructor unset)
(constructor/copy unset)
(read-only-slice-wrapper #false)
@@ -132,13 +134,56 @@
#`(#,(field-ref field #:copy) (#,(field-ref field #:getter) #,object)))
;; The same symbols as in (map field-name fields*), but as different
- ;; identifiers, to avoid field values from accidentbeing used before they
+ ;; identifiers, to avoid field values from accidentally being used
before they
;; have been preprocessed. They are equal as symbols, such that
;; 'procedure-arguments' and the like produce something legible.
(define field-names/different
(map (lambda (f template-id)
(datum->syntax template-id (syntax->datum (field-name f))))
fields* (generate-temporaries fields*)))
+ ;; Syntax. The 'arguments' in the (define* (constructor . arguments)
...).
+ ;; The idea is that default arguments can be passed with
+ ;; arguments = (foo #:key (bar 0) ...).
+ (define constructor-keyword-arguments*
+ (if (eq? constructor-keyword-arguments unset)
+ (map field-name fields*)
+ constructor-keyword-arguments))
+ ;; TODO: check that constructor-keyword-arguments
+ ;; contains all the field names.
+ (define constructor-keyword-arguments*/different
+ (let* ((names->different-alist
+ (map cons (map field-name fields*) field-names/different))
+ (replacement
+ (lambda (i)
+ (let ((matches
+ (partition (lambda (p)
+ (free-identifier=? (car p) i))
+ names->different-alist)))
+ (assert (= (length matches) 1))
+ (cdr (car matches))))))
+ (let loop ((s constructor-keyword-arguments*)
+ (bindings #'()))
+ (syntax-case s ()
+ ((keyword . rest)
+ (keyword? #'keyword)
+ #`(keyword . #,(loop #'rest bindings)))
+ ((i . rest)
+ (identifier? #'i)
+ (let ((j (replacement #'i)))
+ #`(#,j . #,(loop #'rest #`(#,@bindings (i #,j))))))
+ (i ; (... . var)
+ (identifier? #'i)
+ (replacement #'i))
+ (((i . value) . rest)
+ ;; 'value' can refer to previous arguments, so add some
+ ;; 'let' bindings to correct for the renaming. (Untested;
+ ;; there are no users of this at time of writing.)
+ (let ((j (replacement #'i)))
+ #`((#,j (let #,@bindings value))
+ . #,(loop #'rest #`(#,@bindings (i #,j))))))
+ (() s)
+ (_ (pk s)
+ (error "invalid keyword argument syntax in constructor"))))))
(define (preprocess-arguments body)
;; First, use field-names/different as constructor arguments.
;; Otherwise, the preprocessors might accidentally use an
@@ -162,7 +207,7 @@
(fields #,@(map field-clause fields*))
(protocol
(lambda (%make)
- (lambda #,field-names/different
+ (lambda* #,constructor-keyword-arguments*/different
#,constructor-docstring
#,@(map field-verify field-names/different fields*)
#,(preprocess-arguments
@@ -198,9 +243,9 @@
fields*)))))))
#,@(if (eq? constructor/copy* unset)
#'()
- #`((define (#,constructor/copy* #,@(map field-name fields*))
+ #`((define* (#,constructor/copy*
#,@constructor-keyword-arguments*)
#,constructor/copy-docstring
- (#,copy* (#,constructor*
+ (#,copy* (#,constructor* ; <--- FIX
#,@(map field-name fields*))))))))
(define (field-ref field keyword)
--
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.