Change keyword-option-parser to expect defaults as a thunk.

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index b5c427cadebfd9beb34812b818d1652ba55ba9d7..0f558fda40ea253f693360919e510d10d88706df 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -1268,17 +1268,17 @@ USA.
     (guarantee keyword-list? options caller)
     (apply values
           (map (lambda (spec)
-                 (receive (name predicate default-value)
+                 (receive (name predicate get-default)
                      (keyword-option-spec-parts spec)
                    (let ((value (get-keyword-value options name)))
                      (if (default-object? value)
                          (begin
-                           (if (default-object? default-value)
+                           (if (default-object? get-default)
                                (error (string "Missing required option '"
                                               name
                                               "':")
                                       options))
-                           default-value)
+                           (get-default))
                          (guarantee predicate value caller)))))
                keyword-option-specs))))
 
@@ -1286,20 +1286,22 @@ USA.
   (and (list? object)
        (memv (length object) '(2 3))
        (interned-symbol? (car object))
-       (or (unary-procedure? (cadr object))
-          (and (pair? (cadr object))
-               (list-of-type? (cadr object) interned-symbol?)
+       (or (and (unary-procedure? (cadr object))
                (or (null? (cddr object))
-                   (memq (caddr object) (cadr object)))))))
+                   (thunk? (caddr object))))
+          (and (list-of-type? (cadr object) interned-symbol?)
+               (or (null? (cddr object))
+                   (memq (caddr object) (cadr object))
+                   (thunk? (caddr object)))))))
 
 (define (keyword-option-spec-parts spec)
   (values (car spec)
          (if (pair? (cadr spec))
              (lambda (object) (memq object (cadr spec)))
              (cadr spec))
-         (if (null? (cddr spec))
-             (default-object)
-             (caddr spec))))
+         (cond ((null? (cddr spec)) (default-object))
+               ((interned-symbol? (caddr spec)) (lambda () (caddr spec)))
+               (else (caddr spec)))))
 \f
 ;;;; Last pair
 

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index ba1916ccebf18c6c469c596566968351d6ad6ecd..9785a7312107c72369d9fa3a241987e9722ce70d 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -1899,9 +1899,9 @@ USA.
 
 (define-deferred string-joiner-options
   (keyword-option-parser
-   (list (list 'infix string? "")
-        (list 'prefix string? "")
-        (list 'suffix string? ""))))
+   (list (list 'infix string? (lambda () ""))
+        (list 'prefix string? (lambda () ""))
+        (list 'suffix string? (lambda () "")))))
 \f
 ;;;; Splitter
 
@@ -1938,9 +1938,9 @@ USA.
 
 (define-deferred string-splitter-options
   (keyword-option-parser
-   (list (list 'delimiter char-matcher? char-whitespace?)
-        (list 'allow-runs? boolean? #t)
-        (list 'copy? boolean? #f))))
+   (list (list 'delimiter char-matcher? (lambda () char-whitespace?))
+        (list 'allow-runs? boolean? (lambda () #t))
+        (list 'copy? boolean? (lambda () #f)))))
 
 (define (char-matcher->predicate matcher caller)
   (cond ((char? matcher) (char=-predicate matcher))
@@ -1984,8 +1984,8 @@ USA.
 (define-deferred string-trimmer-options
   (keyword-option-parser
    (list (list 'where '(leading trailing both) 'both)
-        (list 'to-trim char-matcher? char-whitespace?)
-        (list 'copy? boolean? #f))))
+        (list 'to-trim char-matcher? (lambda () char-whitespace?))
+        (list 'copy? boolean? (lambda () #f)))))
 
 (define (string-padder . options)
   (receive (where fill-with clip?)
@@ -2021,8 +2021,8 @@ USA.
 (define-deferred string-padder-options
   (keyword-option-parser
    (list (list 'where '(leading trailing) 'leading)
-        (list 'fill-with grapheme-cluster-string? " ")
-        (list 'clip? boolean? #t))))
+        (list 'fill-with grapheme-cluster-string? (lambda () " "))
+        (list 'clip? boolean? (lambda () #t)))))
 \f
 ;;;; Miscellaneous