1 ;;; 8sync --- Asynchronous programming for Guile
2 ;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; This file is part of 8sync.
6 ;;; 8sync is free software: you can redistribute it and/or modify it
7 ;;; under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation, either version 3 of the
9 ;;; License, or (at your option) any later version.
11 ;;; 8sync is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU Lesser General Public License for more details.
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (8sync rmeta-slot)
20 #:use-module (oop goops)
21 #:use-module (srfi srfi-9)
22 #:use-module (ice-9 match)
24 #:export (build-rmeta-slot
25 rmeta-slot-table rmeta-slot-cache
26 maybe-build-rmeta-slot-cache!
29 ;;; This module is for rmeta-slots, aka a recursive-meta-slot.
31 ;;; Recursive meta-slots are recursive because we walk down the
32 ;;; inheritance list until we find a match, and meta because they
33 ;;; are sort of "slots" of their own... alists, rather, where you
34 ;;; are searching for the right key.
36 ;;; Recursive meta-slots have their own cache so access is
39 ;;; A recursive meta-slot definition looks something like this:
41 ;;; ;; Define a class with a meta-slot
42 ;;; (define-class <kah-lassy> ()
43 ;;; (entries #:allocation #:each-subclass
47 ;;; (baz . "basil")))))
50 ;;; (class-rmeta-ref <kah-lassy> 'entries 'foo) => "bar"
51 ;;; (class-rmeta-ref <kah-lassy> 'entries 'baz) => "basil"
53 ;;; ;; Define a subclass
54 ;;; (define-class <sub-lassy> (<kah-lassy>)
55 ;;; (entries #:allocation #:each-subclass
59 ;;; (peanut . "gallery")))))
61 ;;; ;; Access values, and inheritance is preserved
62 ;;; (class-rmeta-ref <sub-lassy> 'entries 'foo) => "foo2"
63 ;;; (class-rmeta-ref <sub-lassy> 'entries 'peanut) => "gallery"
64 ;;; (class-rmeta-ref <sub-lassy> 'entries 'baz) => "basil"
66 (define-record-type <rmeta-slot>
67 (%make-rmeta-slot table cache)
69 (table rmeta-slot-table)
70 (cache rmeta-slot-cache set-rmeta-slot-cache!))
72 (define (build-rmeta-slot table)
74 (%make-rmeta-slot table #f)))
76 ;; Immutable and unique
77 (define %the-nothing (cons '*the* '*nothing*))
79 (define (maybe-build-rmeta-slot-cache! class slot-name
80 equals? cache-set! cache-ref)
81 "Build the rmeta slot cache, if it isn't built already."
83 (class-slot-ref class slot-name))
85 (define cache (make-hash-table))
88 (and (class-slot-definition this-class slot-name)
89 (class-slot-ref this-class slot-name)
90 (let ((this-rmeta (class-slot-ref this-class slot-name)))
91 (for-each (match-lambda
93 ;; Add this value to the list if we haven't yet seen
94 ;; such a definition before
95 (when (eq? (cache-ref cache key %the-nothing)
97 (cache-set! cache key val))))
98 (rmeta-slot-table this-rmeta)))))
99 (class-precedence-list class))
101 ;; If it's alreayd built, this is a no-op.
102 (when (not (rmeta-slot-cache rmeta-slot))
103 (set-rmeta-slot-cache! rmeta-slot (build-cache))))
105 (define* (class-rmeta-ref class slot-name key
106 #:key (equals? equal?)
107 (cache-set! hash-set!)
110 "Search heirarchy of CLASS through the rmeta-slot named SLOT-NAME for
111 value matching KEY. This also calls maybe-build-rmeta-slot-cache! as a side
113 (maybe-build-rmeta-slot-cache! class slot-name
114 equals? cache-set! cache-ref)
115 (cache-ref (rmeta-slot-cache (class-slot-ref class slot-name)) key dflt))