From 1d1ac6930a2d1029c445b78c0709e8ca80075659 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 20 May 2018 16:59:02 -0700 Subject: [PATCH] Move magit-diff-arguments from custom.el to init.el. --- src/runtime/dynamic.scm | 82 ++++++++++++++++++++++++++++++++--------- src/runtime/runtime.pkg | 1 + 2 files changed, 65 insertions(+), 18 deletions(-) diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 1b60a436d..5db74c2f2 100644 --- a/src/runtime/dynamic.scm +++ b/src/runtime/dynamic.scm @@ -64,11 +64,10 @@ USA. (make-general-parameter initial-value (if (default-object? converter) default-parameter-converter - converter) + (guarantee unary-procedure? converter)) default-parameter-merger default-parameter-getter - (and settable? - default-parameter-setter))) + (and settable? default-parameter-setter))) (define (default-parameter-converter value) value) (define (default-parameter-merger old-value new-value) old-value new-value) @@ -85,14 +84,6 @@ USA. 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 @@ -107,15 +98,12 @@ USA. (getter (get-value metadata)))))) (set-parameter-metadata! parameter metadata) parameter)) - + (define (parameterize* new-bindings thunk) (guarantee alist? new-bindings 'parameterize*) (let ((temp (map* bindings - (lambda (p) - (let ((metadata (parameter-metadata (car p)))) - (cons metadata - (convert metadata (cdr p))))) + (lambda (p) (create-binding (car p) (cdr p))) new-bindings))) (let ((swap! (lambda () @@ -123,8 +111,21 @@ USA. unspecific))) (shallow-fluid-bind swap! thunk swap!)))) +(define (create-binding parameter value) + (let ((metadata (parameter-metadata parameter))) + (if (forwarder? metadata) + (create-binding (forwarder-parameter metadata) + ((forwarder-convert-to metadata) value)) + (cons metadata (convert metadata value))))) + (define (parameter-converter parameter) - (metadata-converter (parameter-metadata parameter))) + (let ((metadata (parameter-metadata parameter))) + (if (forwarder? metadata) + (let ((converter1 (forwarder-convert-to metadata)) + (converter2 (parameter-converter parameter))) + (lambda (value) + (converter2 (converter1 value)))) + (metadata-converter metadata)))) (define-record-type (make-metadata value converter merger getter setter) @@ -150,4 +151,49 @@ USA. (define (convert metadata value) ((metadata-merger metadata) (get-value metadata) - ((metadata-converter metadata) value))) \ No newline at end of file + ((metadata-converter metadata) value))) + +(define (make-forwarding-parameter parameter convert-to convert-from) + (guarantee parameter? parameter 'make-forwarding-parameter) + (guarantee unary-procedure? convert-to 'make-forwarding-parameter) + (guarantee unary-procedure? convert-from 'make-forwarding-parameter) + (make-forwarding-parameter-1 parameter convert-to convert-from)) + +(define (make-forwarding-parameter-1 parameter convert-to convert-from) + (let ((parameter* + (if (metadata-setter (skip-forwarders parameter)) + (lambda (#!optional new-value) + (if (default-object? new-value) + (convert-from (parameter)) + (parameter (convert-to new-value)))) + (lambda () + (convert-from (parameter)))))) + (set-parameter-metadata! parameter* + (make-forwarder parameter convert-to convert-from)) + parameter*)) + +(define-record-type + (make-forwarder parameter convert-to convert-from) + forwarder? + (parameter forwarder-parameter) + (convert-to forwarder-convert-to) + (convert-from forwarder-convert-from)) + +(define (skip-forwarders parameter) + (let ((metadata (parameter-metadata parameter))) + (if (forwarder? metadata) + (skip-forwarders (forwarder-parameter metadata)) + metadata))) + +(define (copy-parameter parameter) + (let ((metadata (parameter-metadata parameter))) + (if (forwarder? metadata) + (make-forwarding-parameter-1 (copy-parameter + (forwarder-parameter metadata)) + (forwarder-convert-to metadata) + (forwarder-convert-from metadata)) + (make-general-parameter-1 (metadata-value metadata) + (metadata-converter metadata) + (metadata-merger metadata) + (metadata-getter metadata) + (metadata-setter metadata))))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 9d0b23e70..655a69e37 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4396,6 +4396,7 @@ USA. default-parameter-setter parameter-converter parameter? + make-forwarding-parameter make-general-parameter make-settable-parameter make-unsettable-parameter -- 2.25.1