Add support for value merging in (general) parameters.

diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm
index b6846347e574849d97159f03c11300885fed9f9c..baa35608a7adec7631a740a8bf02d4164abdca97 100644 (file)
--- a/src/runtime/dynamic.scm
+++ b/src/runtime/dynamic.scm
@@ -64,30 +64,46 @@ USA.
                          (if (default-object? converter)
                              default-parameter-converter
                              converter)
+                         default-parameter-merger
                          default-parameter-getter
                          (and settable?
                               default-parameter-setter)))
 
 (define (default-parameter-converter value) value)
+(define (default-parameter-merger old-value new-value) old-value new-value)
 (define (default-parameter-getter value) value)
 (define (default-parameter-setter set-param value) (set-param value))
 
-(define (make-general-parameter initial-value converter getter setter)
+(define (make-general-parameter initial-value converter merger getter setter)
   (guarantee-procedure converter 'make-general-parameter)
   (guarantee-procedure getter 'make-general-parameter)
   (if setter (guarantee-procedure setter 'make-general-parameter))
-  (let* ((metadata (cons converter (converter initial-value)))
-        (get-binding (lambda () (or (assq metadata bindings) metadata)))
+  (make-general-parameter-1 (converter initial-value)
+                           converter
+                           merger
+                           getter
+                           setter))
+
+(define (copy-parameter parameter)
+  (let ((metadata (parameter-metadata parameter)))
+    (make-general-parameter-1 (metadata-value metadata)
+                             (metadata-converter metadata)
+                             (metadata-merger metadata)
+                             (metadata-getter metadata)
+                             (metadata-setter metadata))))
+\f
+(define (make-general-parameter-1 initial-value converter merger getter setter)
+  (let* ((metadata (make-metadata initial-value converter merger getter setter))
         (parameter
          (if setter
              (lambda (#!optional new-value)
                (if (default-object? new-value)
-                   (getter (cdr (get-binding)))
+                   (getter (get-value metadata))
                    (setter (lambda (value)
-                             (set-cdr! (get-binding) value))
-                           (converter new-value))))
+                             (set-value! metadata value))
+                           (convert metadata new-value))))
              (lambda ()
-               (getter (cdr (get-binding)))))))
+               (getter (get-value metadata))))))
     (set-parameter-metadata! parameter metadata)
     parameter))
 
@@ -98,7 +114,7 @@ USA.
               (lambda (p)
                 (let ((metadata (parameter-metadata (car p))))
                   (cons metadata
-                        ((car metadata) (cdr p)))))
+                        (convert metadata (cdr p)))))
               new-bindings)))
     (let ((swap!
           (lambda ()
@@ -107,4 +123,30 @@ USA.
       (shallow-fluid-bind swap! thunk swap!))))
 
 (define (parameter-converter parameter)
-  (car (parameter-metadata parameter)))
\ No newline at end of file
+  (metadata-converter (parameter-metadata parameter)))
+
+(define-record-type <metadata>
+    (make-metadata value converter merger getter setter)
+    metadata?
+  (value metadata-value set-metadata-value!)
+  (converter metadata-converter)
+  (merger metadata-merger)
+  (getter metadata-getter)
+  (setter metadata-setter))
+
+(define (get-value metadata)
+  (let ((p (assq metadata bindings)))
+    (if p
+       (cdr p)
+       (metadata-value metadata))))
+
+(define (set-value! metadata value)
+  (let ((p (assq metadata bindings)))
+    (if p
+       (set-cdr! p value)
+       (set-metadata-value! metadata value))))
+
+(define (convert metadata value)
+  ((metadata-merger metadata)
+   (get-value metadata)
+   ((metadata-converter metadata) value)))
\ No newline at end of file

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 793a72205a523426c61a95f85bcbb34a76cb1fa6..c6438aa84ad4e75f46ab3f9dab035db3932e4f22 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -232,21 +232,21 @@ USA.
                                   parser-table-converter))
 
   (set! runtime-param:parser-associate-positions?
-       (copy-param param:parser-associate-positions?))
+       (copy-parameter param:parser-associate-positions?))
   (set! runtime-param:parser-atom-delimiters
-       (copy-param param:parser-atom-delimiters))
+       (copy-parameter param:parser-atom-delimiters))
   (set! runtime-param:parser-canonicalize-symbols?
-       (copy-param param:parser-canonicalize-symbols?))
+       (copy-parameter param:parser-canonicalize-symbols?))
   (set! runtime-param:parser-constituents
-       (copy-param param:parser-constituents))
+       (copy-parameter param:parser-constituents))
   (set! runtime-param:parser-enable-file-attributes-parsing?
-       (copy-param param:parser-enable-file-attributes-parsing?))
+       (copy-parameter param:parser-enable-file-attributes-parsing?))
   (set! runtime-param:parser-keyword-style
-       (copy-param param:parser-keyword-style))
+       (copy-parameter param:parser-keyword-style))
   (set! runtime-param:parser-radix
-       (copy-param param:parser-radix))
+       (copy-parameter param:parser-radix))
   (set! runtime-param:parser-table
-       (copy-param param:parser-table))
+       (copy-parameter param:parser-table))
 
   (set! hashed-object-interns (make-strong-eq-hash-table))
   (initialize-condition-types!))
@@ -321,10 +321,6 @@ USA.
   (if (not (memv value '(2 8 10 16)))
       (error "Invalid parser radix:" value))
   value)
-
-(define (copy-param param)
-  (make-unsettable-parameter (param)
-                            (parameter-converter param)))
 \f
 (define (handler:whitespace port db ctx char)
   port db ctx char

diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index b35104b96454349d5f9dfaf6b44a0f92adb4584b..2f15d33f611e021fc0a5123f5c35459c6a99c9f0 100644 (file)
--- a/src/runtime/pathnm.scm
+++ b/src/runtime/pathnm.scm
@@ -442,6 +442,7 @@ these rules:
 (define (make-param:default-pathname-defaults)
   (make-general-parameter #f
                          default-parameter-converter
+                         default-parameter-merger
                          defaults-getter
                          defaults-setter))
 

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 80688081eefa7216a58f98e224f71f6bc5ac27d4..82af0c4f4ff90d828f1c6abeeffce5fd6c03b325 100644 (file)
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -802,6 +802,7 @@ USA.
                          (lambda (port)
                            (if port (guarantee port))
                            port)
+                         default-parameter-merger
                          (lambda (port)
                            (or port (nearest-cmdl/port)))
                          default-parameter-setter))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4929d324067b70aa95fa777b59350f829813fe0d..9eb5d0accc404057c63be488cba4e73ad11fa383 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4158,7 +4158,9 @@ USA.
   (parent (runtime))
   (export ()
          (make-parameter make-unsettable-parameter)
+         copy-parameter
          default-parameter-converter
+         default-parameter-merger
          default-parameter-getter
          default-parameter-setter
          parameter-converter

diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm
index db89995a75c7dda4f4fe18aa85c4c64b3915e84c..ed82ad836161403444255f2d3065eeba4fa97162 100644 (file)
--- a/src/runtime/wrkdir.scm
+++ b/src/runtime/wrkdir.scm
@@ -33,6 +33,7 @@ USA.
   (set! working-directory-pathname
        (make-general-parameter #f
                                default-parameter-converter
+                               default-parameter-merger
                                default-parameter-getter
                                wd-setter))
   (reset!)