[gnunet-scheme] 01/02: records: Support keyword arguments in the constructor.

[gnunet]

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.