From 41b32934e39cb7b778e12bf8c61630acc38d2a72 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Tue, 24 Jan 2017 17:27:14 -0600 Subject: [PATCH] rmeta-slot: New module for recursive meta-slot access. This is an abstraction around the core idea driving the actor actions system. It turns out I need this abstraction for mudsync as well, so I'm breaking it out. Pleasantly, it should be much faster now, since a cache is built for each class regarding what key should resolve to what value. * 8sync/rmeta-slot.scm: * tests/test-rmeta-slot.scm: New modules. * Makefile.am: Add them. --- 8sync/rmeta-slot.scm | 113 ++++++++++++++++++++++++++++++++++++++ Makefile.am | 4 +- tests/test-rmeta-slot.scm | 66 ++++++++++++++++++++++ 3 files changed, 182 insertions(+), 1 deletion(-) create mode 100644 8sync/rmeta-slot.scm create mode 100644 tests/test-rmeta-slot.scm diff --git a/8sync/rmeta-slot.scm b/8sync/rmeta-slot.scm new file mode 100644 index 0000000..de85ee9 --- /dev/null +++ b/8sync/rmeta-slot.scm @@ -0,0 +1,113 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright © 2016, 2017 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(define-module (8sync rmeta-slot) + #:use-module (oop goops) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + + #:export (make-rmeta-slot + maybe-build-rmeta-slot-cache! + class-rmeta-ref)) + +;;; This module is for rmeta-slots, aka a recursive-meta-slot. +;;; +;;; Recursive meta-slots are recursive because we walk down the +;;; inheritance list until we find a match, and meta because they +;;; are sort of "slots" of their own... alists, rather, where you +;;; are searching for the right key. +;;; +;;; Recursive meta-slots have their own cache so access is +;;; reasonably fast. +;;; +;;; A recursive meta-slot definition looks something like this: +;;; +;;; ;; Define a class with a meta-slot +;;; (define-class () +;;; (entries #:allocation #:each-subclass +;;; #:init-value +;;; (make-rmeta-slot +;;; `((foo . "bar") +;;; (baz . "basil"))))) +;;; +;;; ;; Access values +;;; (class-rmeta-ref 'entries 'foo) => "bar" +;;; (class-rmeta-ref 'entries 'baz) => "basil" +;;; +;;; ;; Define a subclass +;;; (define-class () +;;; (entries #:allocation #:each-subclass +;;; #:init-value +;;; (make-rmeta-slot +;;; `((foo . "foo2") +;;; (peanut . "gallery"))))) +;;; +;;; ;; Access values, and inheritance is preserved +;;; (class-rmeta-ref 'entries 'foo) => "foo2" +;;; (class-rmeta-ref 'entries 'peanut) => "gallery" +;;; (class-rmeta-ref 'entries 'baz) => "basil" + +(define-record-type + (%make-rmeta-slot table cache) + rmeta-slot? + (table rmeta-slot-table) + (cache rmeta-slot-cache set-rmeta-slot-cache!)) + +(define (make-rmeta-slot table) + (%make-rmeta-slot table #f)) + +;; Immutable and unique +(define %the-nothing (cons '*the* '*nothing*)) + +(define (maybe-build-rmeta-slot-cache! class slot-name + equals? cache-set! cache-ref) + "Build the rmeta slot cache, if it isn't built already." + (define rmeta-slot + (class-slot-ref class slot-name)) + (define (build-cache) + (define cache (make-hash-table)) + (for-each + (lambda (this-class) + (and (class-slot-definition this-class slot-name) + (class-slot-ref this-class slot-name) + (let ((this-rmeta (class-slot-ref this-class slot-name))) + (for-each (match-lambda + ((key . val) + ;; Add this value to the list if we haven't yet seen + ;; such a definition before + (when (eq? (cache-ref cache key %the-nothing) + %the-nothing) + (cache-set! cache key val)))) + (rmeta-slot-table this-rmeta))))) + (class-precedence-list class)) + cache) + ;; If it's alreayd built, this is a no-op. + (when (not (rmeta-slot-cache rmeta-slot)) + (set-rmeta-slot-cache! rmeta-slot (build-cache)))) + +(define* (class-rmeta-ref class slot-name key + #:key (equals? eq?) + (cache-set! hashq-set!) + (cache-ref hashq-ref) + dflt) + "Search heirarchy of CLASS through the rmeta-slot named SLOT-NAME for +value matching KEY. This also calls maybe-build-rmeta-slot-cache! as a side +effect." + (maybe-build-rmeta-slot-cache! class slot-name + equals? cache-set! cache-ref) + (cache-ref (rmeta-slot-cache (class-slot-ref class slot-name)) key dflt)) diff --git a/Makefile.am b/Makefile.am index d0dd1a4..926d755 100644 --- a/Makefile.am +++ b/Makefile.am @@ -51,6 +51,7 @@ SOURCES = \ 8sync/actors.scm \ 8sync/debug.scm \ 8sync/ports.scm \ + 8sync/rmeta-slot.scm \ 8sync/contrib/base64.scm \ 8sync/contrib/sha-1.scm \ 8sync/systems/irc.scm \ @@ -63,7 +64,8 @@ SOURCES = \ TESTS = \ tests/test-agenda.scm \ - tests/test-actors.scm + tests/test-actors.scm \ + tests/test-rmeta-slot.scm TEST_EXTENSIONS = .scm diff --git a/tests/test-rmeta-slot.scm b/tests/test-rmeta-slot.scm new file mode 100644 index 0000000..0fd4b6f --- /dev/null +++ b/tests/test-rmeta-slot.scm @@ -0,0 +1,66 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2017 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(define-module (tests test-rmeta-slot) + #:use-module (srfi srfi-64) + #:use-module (8sync rmeta-slot) + #:use-module (oop goops) + #:use-module (tests utils)) + +(test-begin "test-rmeta-slot") + +;; Define a class +(define-class () + (entries #:allocation #:each-subclass + #:init-value + (make-rmeta-slot + `((foo . "bar") + (baz . "basil"))))) + +(test-equal "bar" + (class-rmeta-ref 'entries 'foo)) +(test-equal "basil" + (class-rmeta-ref 'entries 'baz)) + +;; Define a subclass + +(define-class () + (entries #:allocation #:each-subclass + #:init-value + (make-rmeta-slot + `((foo . "foo2") + (peanut . "gallery"))))) + +;; Access values, and inheritance is preserved +(test-equal "foo2" + (class-rmeta-ref 'entries 'foo)) +(test-equal "gallery" + (class-rmeta-ref 'entries 'peanut)) +(test-equal "basil" + (class-rmeta-ref 'entries 'baz)) + +;; Not defined +(test-equal #f + (class-rmeta-ref 'entries 'not-defined)) +;; Not defined, with default +(test-equal "no-way" + (class-rmeta-ref 'entries 'not-defined + #:dflt "no-way")) + +(test-end "test-rmeta-slot") +(test-exit) -- 2.31.1