From 10f0f3f9d0b5257c69a7c03860063058d7b62fc8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 29 Apr 2018 15:57:51 -0700 Subject: [PATCH] Convert metadata tables to be bundles. --- src/runtime/bundle.scm | 12 ++++++++++-- src/runtime/char.scm | 4 ++-- src/runtime/compound-predicate.scm | 4 ++-- src/runtime/dynamic.scm | 17 +++++++++-------- src/runtime/global.scm | 29 +++++++---------------------- src/runtime/hash-table.scm | 6 +++--- src/runtime/host-adapter.scm | 8 ++++++++ src/runtime/predicate.scm | 6 +++--- src/runtime/runtime.pkg | 3 +-- src/runtime/textual-port.scm | 10 +++++----- tests/unit-testing.scm | 6 +++--- 11 files changed, 53 insertions(+), 52 deletions(-) diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm index ec15d37af..d2bf7ec1e 100644 --- a/src/runtime/bundle.scm +++ b/src/runtime/bundle.scm @@ -65,16 +65,24 @@ USA. (record-predicate type)) (define (alist->bundle type alist) - (guarantee bundle-type? type 'alist->bundle) (guarantee %bundle-alist? alist 'alist->bundle) ((record-constructor type) (alist-copy alist))) +(defer-boot-action 'predicate-relations + (lambda () + (set! alist->bundle + (named-lambda (alist->bundle type alist) + (guarantee bundle-type? type 'alist->bundle) + (guarantee %bundle-alist? alist 'alist->bundle) + ((record-constructor type) (alist-copy alist)))) + unspecific)) + (define (%bundle-alist? object) (and (alist? object) (every (lambda (p) (symbol? (car p))) object))) - + (define-record-type (%unused% alist) ;change to #f after 9.3 release bundle? diff --git a/src/runtime/char.scm b/src/runtime/char.scm index 48147a398..514de9b8a 100644 --- a/src/runtime/char.scm +++ b/src/runtime/char.scm @@ -684,8 +684,8 @@ USA. (add-boot-init! (lambda () (let ((table (make-alist-metadata-table))) - (set! get-char-codec (table 'get)) - (set! set-char-codec! (table 'put!)) + (set! get-char-codec (bundle-ref table 'get)) + (set! set-char-codec! (bundle-ref table 'put!)) unspecific))) (define (define-char-codec name codec) diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index c6f2cda05..94c88c1b5 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -122,8 +122,8 @@ USA. (add-boot-init! (lambda () (let ((table (make-alist-metadata-table))) - (set! compound-operator-builder (table 'get)) - (set! define-compound-operator (table 'put!)) + (set! compound-operator-builder (bundle-ref table 'get)) + (set! define-compound-operator (bundle-ref table 'put!)) unspecific))) (add-boot-init! diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 23b0f3864..1b60a436d 100644 --- a/src/runtime/dynamic.scm +++ b/src/runtime/dynamic.scm @@ -36,20 +36,21 @@ USA. (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)) + (set! parameter? (bundle-ref implementation 'has?)) + (set! parameter-metadata (bundle-ref implementation 'get)) + (set! set-parameter-metadata! (bundle-ref implementation 'put!)) + (set! get-metadata-alist (bundle-ref 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))) +(add-boot-init! + (lambda () + (let ((implementation (make-hashed-metadata-table))) + (implementation 'put-alist! (get-metadata-alist)) + (use-metadata-implementation! implementation)))) (define-guarantee parameter "parameter") diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 5975e66de..202671067 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -494,6 +494,9 @@ USA. ;;;; Metadata tables +(define + (make-bundle-type 'metadata-table)) + (define (make-alist-metadata-table) (let ((alist '())) @@ -540,17 +543,8 @@ USA. (put! (car p) (cdr p))) alist*)) - (lambda (operator) - (case operator - ((has?) has?) - ((get) get) - ((put!) put!) - ((intern!) intern!) - ((delete!) delete!) - ((get-alist) get-alist) - ((put-alist!) put-alist!) - ((get-if-available) get) - (else (error "Unknown operator:" operator)))))) + (bundle + has? get put! intern! delete! get-alist put-alist!))) (define (make-hashed-metadata-table) (let ((table (make-key-weak-eqv-hash-table))) @@ -580,17 +574,8 @@ USA. (put! (car p) (cdr p))) alist*)) - (lambda (operator) - (case operator - ((has?) has?) - ((get) get) - ((put!) put!) - ((intern!) intern!) - ((delete!) delete!) - ((get-alist) get-alist) - ((put-alist!) put-alist!) - ((get-if-available) get) - (else (error "Unknown operator:" operator)))))) + (bundle + has? get put! intern! delete! get-alist put-alist!))) ;;;; Builder for vector-like sequences diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm index 53b424306..aa9f1dcd2 100644 --- a/src/runtime/hash-table.scm +++ b/src/runtime/hash-table.scm @@ -1387,9 +1387,9 @@ USA. (add-boot-init! (lambda () (let ((table (make-hashed-metadata-table))) - (set! equality-predicate? (table 'has?)) - (set! %equality-predicate-properties (table 'get)) - (set! %set-equality-predicate-properties! (table 'put!))) + (set! equality-predicate? (bundle-ref table 'has?)) + (set! %equality-predicate-properties (bundle-ref table 'get)) + (set! %set-equality-predicate-properties! (bundle-ref table 'put!))) (set-equality-predicate-properties! eq? hash-by-identity #t) (set-equality-predicate-properties! eqv? hash-by-eqv #t) (set-equality-predicate-properties! equal? hash-by-equal #t) diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 4841e387d..a9cac454b 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -81,6 +81,14 @@ USA. (->environment '(runtime hash-table)) 'hash-table-constructor)) + (if (unbound? env 'bundle) + (eval '(define-syntax bundle + (syntax-rules () + ((_ predicate name ...) + (alist->bundle predicate + (list (cons 'name name) ...))))) + env)) + (for-each (lambda (old-name) (provide-rename env old-name (symbol 'scode- old-name))) '(access-environment diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm index 35590d14f..53d59cf0a 100644 --- a/src/runtime/predicate.scm +++ b/src/runtime/predicate.scm @@ -112,9 +112,9 @@ USA. (add-boot-init! (lambda () (let ((table (make-hashed-metadata-table))) - (set! predicate? (table 'has?)) - (set! get-predicate-tag (table 'get)) - (set! set-predicate-tag! (table 'put!))) + (set! predicate? (bundle-ref table 'has?)) + (set! get-predicate-tag (bundle-ref table 'get)) + (set! set-predicate-tag! (bundle-ref table 'put!))) (set! predicate->dispatch-tag (named-lambda (predicate->dispatch-tag predicate) (let ((tag (get-predicate-tag predicate #f))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 0c557db51..f1eb12622 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4359,8 +4359,7 @@ USA. make-general-parameter make-settable-parameter make-unsettable-parameter - parameterize*) - (initialization (initialize-package!))) + parameterize*)) (define-package (runtime stream) (files "stream") diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm index 6d1c8f72b..55c09c15b 100644 --- a/src/runtime/textual-port.scm +++ b/src/runtime/textual-port.scm @@ -507,22 +507,22 @@ USA. (define (port-property port name #!optional default-value) (guarantee symbol? name 'port-property) - (((port-metadata port) 'get) name default-value)) + ((port-metadata port) 'get name default-value)) (define (set-port-property! port name value) (guarantee symbol? name 'set-port-property!) - (((port-metadata port) 'put!) name value)) + ((port-metadata port) 'put! name value)) (define (intern-port-property! port name get-value) (guarantee symbol? name 'intern-port-property!) - (((port-metadata port) 'intern!) name get-value)) + ((port-metadata port) 'intern! name get-value)) (define (remove-port-property! port name) (guarantee symbol? name 'remove-port-property!) - (((port-metadata port) 'delete!) name)) + ((port-metadata port) 'delete! name)) (define (port-properties port) - (alist-copy (((port-metadata port) 'get-alist)))) + (alist-copy ((port-metadata port) 'get-alist))) (define (transcribe-char char port) (let ((tport (textual-port-transcript port))) diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index 9ba6530c1..28f914bfb 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -454,9 +454,9 @@ USA. (define comparator-metadata) (define set-comparator-metadata!) (let ((table (make-hashed-metadata-table))) - (set! comparator? (table 'has?)) - (set! comparator-metadata (table 'get)) - (set! set-comparator-metadata! (table 'put!)) + (set! comparator? (bundle-ref table 'has?)) + (set! comparator-metadata (bundle-ref table 'get)) + (set! set-comparator-metadata! (bundle-ref table 'put!)) unspecific) (define-for-tests (define-comparator comparator name) -- 2.25.1