Refactor parameter/fluid implementation into one.

Also use metadata tables instead of entities, and move syntax into mit-macros.

diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm
index a7b9a0b045dd4111428aec2af331fb028366a37d..873492491f256984831aadabcde558478736dcb1 100644 (file)
--- a/src/runtime/dynamic.scm
+++ b/src/runtime/dynamic.scm
@@ -24,47 +24,97 @@ USA.
 
 |#
 
-;;;; Fluids and Parameters
+;;;; Parameters
 ;;; package: (runtime dynamic)
 
 (declare (usual-integrations))
 \f
-;; The current thread's fluid and parameter bindings.
-(define bindings '())
+(define bindings '())      ; The current thread's parameter bindings.
+(define parameter?)
+(define parameter-metadata)
+(define set-parameter-metadata!)
+(define get-metadata-alist)
+
+(define (use-metadata-implementation! implementation)
+  (set! parameter? (implementation 'has?))
+  (set! parameter-metadata (implementation 'get))
+  (set! set-parameter-metadata! (implementation 'put!))
+  (set! get-metadata-alist (implementation 'get-alist))
+  unspecific)
+
+;; Use alist for cold-load.
+(use-metadata-implementation! (make-alist-metadata-table))
+
+;; Later move metadata to hash table.
+(define (initialize-package!)
+  (let ((implementation (make-hashed-metadata-table)))
+    ((implementation 'put-alist!) (get-metadata-alist))
+    (use-metadata-implementation! implementation)))
 
-(define (apply-bindings new-bindings thunk)
-  (let ((swap!
-        (lambda ()
-          (set! bindings (set! new-bindings (set! bindings)))
-          unspecific)))
-    (shallow-fluid-bind swap! thunk swap!)))
+(define-guarantee parameter "parameter")
 
-;;;; Fluids
+(define (make-parameter init #!optional converter)
+  (let ((converter
+        (if (default-object? converter)
+            (lambda (x) x)
+            converter)))
+    (let ((metadata (cons converter (converter init))))
+
+      (define (get-binding)
+       (or (assq metadata bindings)
+           metadata))
+
+      (define (get)
+       (cdr (get-binding)))
+
+      (define (set new-value)
+       (let ((binding (get-binding))
+             (converted (converter new-value)))
+         (let ((old-value (cdr binding)))
+           (set-cdr! binding converted)
+           old-value)))
+
+      (let ((parameter
+            (lambda (#!optional new-value)
+              (if (default-object? new-value)
+                  (get)
+                  (set new-value)))))
+       (set-parameter-metadata! parameter metadata)
+       parameter))))
 
-(define-structure fluid
-  value)
+(define (parameterize* new-bindings thunk)
+  (guarantee-alist new-bindings 'parameterize*)
+  (let ((temp
+        (map* bindings
+              (lambda (p)
+                (let ((metadata (parameter-metadata (car p))))
+                  (cons metadata
+                        ((car metadata) (cdr p)))))
+              new-bindings)))
+    (let ((swap!
+          (lambda ()
+            (set! bindings (set! temp (set! bindings)))
+            unspecific)))
+      (shallow-fluid-bind swap! thunk swap!))))
+\f
+;;;; Fluids (to be eliminated)
+
+(define (fluid? object)
+  (parameter? object))
 
-(define-guarantee fluid "fluid")
+(define (make-fluid value)
+  (make-parameter value))
 
 (define (fluid f)
-  (guarantee-fluid f 'fluid)
-  (let ((entry (assq f bindings)))
-    (if entry
-       (cdr entry)
-       (fluid-value f))))
+  (guarantee-parameter f 'fluid)
+  (f))
 
 (define (set-fluid! f val)
-  (guarantee-fluid f 'set-fluid!)
-  (let ((entry (assq f bindings)))
-    (if entry
-       (set-cdr! entry val)
-       (set-fluid-value! f val))))
+  (guarantee-parameter f 'set-fluid!)
+  (f val))
 
 (define (let-fluid fluid value thunk)
-  (guarantee-fluid fluid 'let-fluid)
-  (guarantee-thunk thunk 'let-fluid)
-  (apply-bindings (cons (cons fluid value) bindings)
-                 thunk))
+  (parameterize* (list (cons fluid value)) thunk))
 
 (define (let-fluids . args)
   (let loop
@@ -73,77 +123,7 @@ USA.
     (if (not (pair? args))
        (error "Ill-formed let-fluids arguments:" args))
     (if (pair? (cdr args))
-       (begin
-         (guarantee-fluid (car args) 'let-fluids)
-         (loop (cddr args)
-               (cons (cons (car args) (cadr args))
-                     new-bindings)))
-       (begin
-         (guarantee-thunk (car args) 'let-fluids)
-         (apply-bindings (append! new-bindings bindings)
-                         (car args))))))
-\f
-;;;; Parameters
-
-(define-structure parameter-metadata
-  value
-  converter)
-
-(define (parameter? p)
-  (and (entity? p)
-       (parameter-metadata? (entity-extra p))))
-
-(define-guarantee parameter "parameter")
-
-(define (make-parameter init #!optional converter)
-  (let ((converter
-        (if (default-object? converter)
-            identity-procedure
-            (begin
-              (guarantee-procedure-of-arity converter 1 'make-parameter)
-              converter))))
-    (make-entity (lambda (self)
-                  (let ((entry (assq self bindings)))
-                    (if entry
-                        (cdr entry)
-                        (parameter-metadata-value (entity-extra self)))))
-                (make-parameter-metadata (converter init)
-                                         converter))))
-
-(define (set-parameter! p v)
-  (let ((metadata (entity-extra p)))
-    (let ((entry (assq p bindings))
-         (converted ((parameter-metadata-converter metadata) v)))
-      (if entry
-         (set-cdr! entry converted)
-         (set-parameter-metadata-value! metadata converted)))))
-
-(define (parameter-converter p)
-  (parameter-metadata-converter (entity-extra p)))
-
-(define-syntax parameterize
-  (syntax-rules ()
-    ((_ ((param value) binding ...) body ...)
-     (parameterize-helper ((param value) binding ...) () body ...))))
-
-(define-syntax parameterize-helper
-  (syntax-rules ()
-    ((_ ((param value) binding ...) (extension ...) body ...)
-     (parameterize-helper (binding ...)
-                         ((cons param value) extension ...)
-                         body ...))
-    ((_ () (extension ...) body ...)
-     (parameterize* (list extension ...)
-                   (lambda () body ...)))))
-
-(define (parameterize* new-bindings thunk)
-  (guarantee-alist new-bindings 'parameterize*)
-  (apply-bindings
-   (append! (map (lambda (p)
-                  (let ((parameter (car p))
-                        (value (cdr p)))
-                    (cons parameter
-                          ((parameter-converter parameter) value))))
-                new-bindings)
-           bindings)
-   thunk))
\ No newline at end of file
+       (loop (cddr args)
+             (cons (cons (car args) (cadr args))
+                   new-bindings))
+       (parameterize* new-bindings (car args)))))
\ No newline at end of file

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index b692043f7113c26ebc64c8beb9f8696bc4347e52..08fd218b8eb59c3e548e14c696a36c6056400430 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -451,6 +451,7 @@ USA.
    (RUNTIME 2D-PROPERTY)
    (RUNTIME HASH-TABLE)
    (RUNTIME HASH)
+   (RUNTIME DYNAMIC)
    (RUNTIME REGULAR-SEXPRESSION)
    ;; Microcode data structures
    (RUNTIME HISTORY)

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 3a721e7e922dab4cc2c79847de4e429a7e11fc02..43e17efcf33f01ebe5e08f860fd75af90ce2151f 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -692,6 +692,22 @@ USA.
              ,r-unspecific)
            (,r-shallow-fluid-bind ,swap! ,body ,swap!)))))))
 
+(define-syntax :parameterize
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare
+     (syntax-check '(KEYWORD (* (EXPRESSION EXPRESSION)) + FORM) form)
+     (let ((r-parameterize* (rename 'parameterize*))
+          (r-list (rename 'list))
+          (r-cons (rename 'cons))
+          (r-lambda (rename 'lambda)))
+       `(,r-parameterize*
+        (,r-list
+         ,@(map (lambda (binding)
+                  `(,r-cons ,(car binding) ,(cadr binding)))
+                (cadr form)))
+        (,r-lambda () ,@(cddr form)))))))
+\f
 (define-syntax :local-declare
   (er-macro-transformer
    (lambda (form rename compare)
@@ -720,4 +736,4 @@ USA.
   (syntax-rules ()
     ((ASSERT condition . extra)
      (IF (NOT condition)
-         (ERROR "Assertion failed:" 'condition . extra)))))
+         (ERROR "Assertion failed:" 'condition . extra)))))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 56697211231a03b39b9ed804fb747a7ba8471e8d..ac828021a093316afee269dca02218aece20ca13 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4579,19 +4579,15 @@ USA.
   (parent (runtime))
   (export ()
          fluid?
-         guarantee-fluid
          make-fluid
          fluid
          set-fluid!
          let-fluid
          let-fluids
          parameter?
-         guarantee-parameter
          make-parameter
-         set-parameter!
-         parameterize
-         parameter-converter
-         parameterize*))
+         parameterize*)
+  (initialization (initialize-package!)))
 
 (define-package (runtime stream)
   (files "stream")
@@ -4909,6 +4905,7 @@ USA.
          (letrec :letrec)
          (letrec* :letrec*)
          (local-declare :local-declare)
+         (parameterize :parameterize)
          (quasiquote :quasiquote)
          (receive :receive))
   (export (runtime)