From: Chris Hanson Date: Sat, 26 Mar 2016 07:59:54 +0000 (-0700) Subject: Add support for value merging in (general) parameters. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~67 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cf69c0b2bf13bc076ebfae36577dc2af295d82d1;p=mit-scheme.git Add support for value merging in (general) parameters. --- diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index b6846347e..baa35608a 100644 --- 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)))) + +(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 + (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 793a72205..c6438aa84 100644 --- 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))) (define (handler:whitespace port db ctx char) port db ctx char diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index b35104b96..2f15d33f6 100644 --- 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 80688081e..82af0c4f4 100644 --- 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 4929d3240..9eb5d0acc 100644 --- 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 db89995a7..ed82ad836 100644 --- 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!)