From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 24 Apr 2018 06:16:18 +0000 (-0700)
Subject: Change keyword-option-parser to expect defaults as a thunk.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~115
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=af10e37373567b8bfd46bc6d490f1babf1d8cd48;p=mit-scheme.git

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

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index b5c427cad..0f558fda4 100644
--- 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)))))
 
 ;;;; Last pair
 
diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index ba1916cce..9785a7312 100644
--- 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 () "")))))
 
 ;;;; 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)))))
 
 ;;;; Miscellaneous