From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 28 Feb 2016 01:39:36 +0000 (-0800)
Subject: Split make-parameter into settable and unsettable variants.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~113
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=36e3727880e735cd47c2f5b90262d42d5f5084fa;p=mit-scheme.git

Split make-parameter into settable and unsettable variants.

* Default is settable, but that might want to be reconsidered.
* Parameters defined in runtime should probably be made explicit.
* Rename make-parameter* to make-general-parameter.
---

diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm
index 35db0bd68..cb8700f2a 100644
--- a/src/runtime/dynamic.scm
+++ b/src/runtime/dynamic.scm
@@ -53,22 +53,34 @@ USA.
 
 (define-guarantee parameter "parameter")
 
-(define (make-parameter initial-value #!optional write-converter)
+(define (make-unsettable-parameter initial-value #!optional converter)
+  (make-parameter-internal initial-value converter #f))
+
+(define (make-settable-parameter initial-value #!optional converter)
+  (make-parameter-internal initial-value converter #t))
+
+(define (make-parameter-internal initial-value converter settable?)
   (let ((noop (lambda (x) x)))
-    (make-parameter* initial-value
-		     noop
-		     (if (default-object? write-converter)
-			 noop
-			 write-converter))))
-
-(define (make-parameter* initial-value read-converter write-converter)
-  (let* ((metadata (cons write-converter (write-converter initial-value)))
+    (make-general-parameter initial-value
+			    (if (default-object? converter)
+				noop
+				converter)
+			    noop
+			    settable?)))
+
+(define (make-general-parameter initial-value converter reader settable?)
+  (guarantee-procedure converter 'make-general-parameter)
+  (guarantee-procedure reader 'make-general-parameter)
+  (let* ((metadata (cons converter (converter initial-value)))
+	 (get-binding (lambda () (or (assq metadata bindings) metadata)))
 	 (parameter
-	  (lambda (#!optional new-value)
-	    (let ((p (or (assq metadata bindings) metadata)))
-	      (if (default-object? new-value)
-		  (read-converter (cdr p))
-		  (set-cdr! p (write-converter new-value)))))))
+	  (if settable?
+	      (lambda (#!optional new-value)
+		(if (default-object? new-value)
+		    (reader (cdr (get-binding)))
+		    (set-cdr! (get-binding) (converter new-value))))
+	      (lambda ()
+		(reader (cdr (get-binding)))))))
     (set-parameter-metadata! parameter metadata)
     parameter))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 67f6bbb05..450c38ac7 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4581,9 +4581,11 @@ USA.
   (files "dynamic")
   (parent (runtime))
   (export ()
+	  (make-parameter make-settable-parameter)
 	  parameter?
-	  make-parameter
-	  make-parameter*
+	  make-general-parameter
+	  make-settable-parameter
+	  make-unsettable-parameter
 	  parameterize*)
   (initialization (initialize-package!)))