records: Correct calling convention for constructor.

Oops another bug ...

The constructor now sometimes expects keyword arguments!

* gnu/gnunet/utils/records.scm
(process)[keywordify]: New procedure.
(process)[copy*]: Use it, and add a TODO about apparent bug.
(process)[constructor/copy*]: Use it.

1 files changed, 36 insertions, 7 deletions

diff --git a/gnu/gnunet/utils/records.scm b/gnu/gnunet/utils/records.scm
index fc001e1..d7fc8a1 100644
--- a/gnu/gnunet/utils/records.scm
+++ b/gnu/gnunet/utils/records.scm
@@ -19,13 +19,14 @@
   (export define-record-type*)
   ;; keyword? cannot be used from (srfi srfi-88) because that sets
   ;; a reader option.
-  (import (only (guile) define* lambda* keyword? error define-values pk syntax-error)
+  (import (only (guile) define* lambda* keyword? error define-values pk syntax-error
+		symbol->keyword)
 	  (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* length)
+		=> let* length list)
 	  (only (rnrs control) when unless)
 	  (only (rnrs syntax-case)
 		syntax quasisyntax unsyntax unsyntax-splicing syntax-case
@@ -184,6 +185,32 @@
 	      (() s)
 	      (_ (pk s)
 		 (error "invalid keyword argument syntax in constructor"))))))
+      (define (keywordify positional-arguments keyword-signature)
+	(define (keywordify* positional-arguments keyword-signature positional?)
+	  (define (something id rest)
+	    (assert (identifier? id))
+	    (assert (pair? positional-arguments))
+	    #`(#,@(if positional?
+		      #'()
+		      #`(#,(datum->syntax #f (symbol->keyword (syntax->datum id)))))
+	       #,(car positional-arguments)
+	       . #,(keywordify* (cdr positional-arguments)
+				rest
+				positional?)))
+	  (syntax-case keyword-signature ()
+	    ((#:rest _) ; untested
+	     (begin
+	       (assert (= (length positional-arguments) 1))
+	       #`(#,(car positional-arguments))))
+	    ((#:allow-other-keys . r)
+	     (keywordify* positional-arguments #'r positional?))
+	    ((#:key . r)
+	     (keywordify* positional-arguments #'r #false))
+	    (((i default) . r) (something #'i #'r))
+	    ((i . r)
+	     (something #'i #'r))
+	    (() #'((list)))))
+	(keywordify* positional-arguments keyword-signature #true))
       (define (preprocess-arguments body)
 	;; First, use field-names/different as constructor arguments.
 	;; Otherwise, the preprocessors might accidentally use an
@@ -238,15 +265,17 @@
 		   ;; If not, just copy fields one-by-one.
 		   (#false
 		    #`((define (#,copy* object)
-			 (#,constructor
-			  #,@(map (lambda (f) (field-copy f #'object))
-				  fields*)))))))
+			 (apply #,constructor ; TODO: why not constructor*?
+				#,@(keywordify (map (lambda (f) (field-copy f #'object))
+						    fields*)
+					       constructor-keyword-arguments*/different)))))))
 	  #,@(if (eq? constructor/copy* unset)
 		 #'()
 		 #`((define* (#,constructor/copy* #,@constructor-keyword-arguments*)
 		      #,constructor/copy-docstring
-		      (#,copy* (#,constructor* ; <--- FIX
-				#,@(map field-name fields*))))))))
+		      (#,copy* (apply #,constructor*
+				      #,@(keywordify (map field-name fields*)
+						     constructor-keyword-arguments*/different))))))))
 
     (define (field-ref field keyword)
       (match (assoc keyword (cdr field))