[gnunet-scheme] 04/08: utils/records: Give preprocessors access to previous fields.

[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 eded264912a17800e90012c49a17491ee72e366b
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Feb 9 15:22:36 2023 +0100

    utils/records: Give preprocessors access to previous fields.
    
    * gnu/gnunet/utils/records.scm (process): Implement it.
---
 gnu/gnunet/utils/records.scm | 49 +++++++++++++++++++++++++++++++++-----------
 1 file changed, 37 insertions(+), 12 deletions(-)

diff --git a/gnu/gnunet/utils/records.scm b/gnu/gnunet/utils/records.scm
index b2f0b03..a3839ff 100644
--- a/gnu/gnunet/utils/records.scm
+++ b/gnu/gnunet/utils/records.scm
@@ -19,16 +19,17 @@
   (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)
+  (import (only (guile) define* 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?)
+               string? values map assert car cdr cadr cddr let or pair?
+               => let*)
          (only (rnrs control) when unless)
          (only (rnrs syntax-case)
                syntax quasisyntax unsyntax unsyntax-splicing syntax-case
-               syntax->datum identifier? generate-temporaries)
+               syntax->datum identifier? generate-temporaries datum->syntax)
          (only (rnrs records syntactic) define-record-type)
          (only (srfi srfi-1) assoc)
          ;; in generated code
@@ -110,9 +111,9 @@
        (maybe-identifier-maybe-with-docstring constructor/copy))
       (define (field-name field) ; -> identifier
        (car field))
-      (define (field-verify field)
+      (define (field-verify field-name/different field)
        (if (field-set field #:predicate)
-           #`(assert (#,(field-ref field #:predicate) #,(field-name field)))
+           #`(assert (#,(field-ref field #:predicate) #,field-name/different))
            #'#true)) ; exact value doesn't matter
       (define (field-compare field this that)
        (define g (field-ref field #:getter)) ; always defined
@@ -127,21 +128,45 @@
        #`(immutable #,(field-name field)
                     #,(field-ref field #:getter)))
       ;; TODO bail out if unrecognised field settings
-      (define (field-preprocess field)
-       (if (field-set field #:preprocess)
-           #`(#,(field-ref field #:preprocess) #,(field-name field))
-           (field-name field)))
       (define (field-copy field object)
        #`(#,(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
+      ;; 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*)))
+      (define (preprocess-arguments body)
+       ;; First, use field-names/different as constructor arguments.
+       ;; Otherwise, the preprocessors might accidentally use an
+       ;; un-preprocessed field.  Then, gradually
+       ;; re-introduce the field names, but with their preprocessed
+       ;; values.  Lastly, insert 'body'.
+       (define (preprocess field-name/different field)
+         #`(#,(field-name field)
+            #,(if (field-set field #:preprocess)
+                  (syntax-case (field-ref field #:preprocess) (=>)
+                    ((=> expr)
+                     #`(let ((#,(field-name field) #,field-name/different))
+                         expr))
+                    (proc #`(proc #,field-name/different)))
+                  ;; nothing to preprocess, just unstash things.
+                  field-name/different)))
+       #`(let* #,(map preprocess field-names/different fields*)
+           #,body))
       #`(begin
          (define-record-type (#,<type> #,constructor* #,type?)
            (fields #,@(map field-clause fields*))
            (protocol
             (lambda (%make)
-              (lambda #,(map field-name fields*)
+              (lambda #,field-names/different
                 #,constructor-docstring
-                #,@(map field-verify fields*)
-                (%make #,@(map field-preprocess fields*)))))
+                #,@(map field-verify field-names/different fields*)
+                #,(preprocess-arguments
+                   #`(%make #,@(map field-name fields*))))))
            (sealed #true)
            (opaque #true))
          #,@(if (eq? equality* unset)

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.