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 (make-rmeta-slot
25 maybe-build-rmeta-slot-cache!
28 ;;; This module is for rmeta-slots, aka a recursive-meta-slot.
30 ;;; Recursive meta-slots are recursive because we walk down the
31 ;;; inheritance list until we find a match, and meta because they
32 ;;; are sort of "slots" of their own... alists, rather, where you
33 ;;; are searching for the right key.
35 ;;; Recursive meta-slots have their own cache so access is
38 ;;; A recursive meta-slot definition looks something like this:
40 ;;; ;; Define a class with a meta-slot
41 ;;; (define-class <kah-lassy> ()
42 ;;; (entries #:allocation #:each-subclass
46 ;;; (baz . "basil")))))
49 ;;; (class-rmeta-ref <kah-lassy> 'entries 'foo) => "bar"
50 ;;; (class-rmeta-ref <kah-lassy> 'entries 'baz) => "basil"
52 ;;; ;; Define a subclass
53 ;;; (define-class <sub-lassy> (<kah-lassy>)
54 ;;; (entries #:allocation #:each-subclass
58 ;;; (peanut . "gallery")))))
60 ;;; ;; Access values, and inheritance is preserved
61 ;;; (class-rmeta-ref <sub-lassy> 'entries 'foo) => "foo2"
62 ;;; (class-rmeta-ref <sub-lassy> 'entries 'peanut) => "gallery"
63 ;;; (class-rmeta-ref <sub-lassy> 'entries 'baz) => "basil"
65 (define-record-type <rmeta-slot>
66 (%make-rmeta-slot table cache)
68 (table rmeta-slot-table)
69 (cache rmeta-slot-cache set-rmeta-slot-cache!))
71 (define (make-rmeta-slot table)
72 (%make-rmeta-slot table #f))
74 ;; Immutable and unique
75 (define %the-nothing (cons '*the* '*nothing*))
77 (define (maybe-build-rmeta-slot-cache! class slot-name
78 equals? cache-set! cache-ref)
79 "Build the rmeta slot cache, if it isn't built already."
81 (class-slot-ref class slot-name))
83 (define cache (make-hash-table))
86 (and (class-slot-definition this-class slot-name)
87 (class-slot-ref this-class slot-name)
88 (let ((this-rmeta (class-slot-ref this-class slot-name)))
89 (for-each (match-lambda
91 ;; Add this value to the list if we haven't yet seen
92 ;; such a definition before
93 (when (eq? (cache-ref cache key %the-nothing)
95 (cache-set! cache key val))))
96 (rmeta-slot-table this-rmeta)))))
97 (class-precedence-list class))
99 ;; If it's alreayd built, this is a no-op.
100 (when (not (rmeta-slot-cache rmeta-slot))
101 (set-rmeta-slot-cache! rmeta-slot (build-cache))))
103 (define* (class-rmeta-ref class slot-name key
105 (cache-set! hashq-set!)
106 (cache-ref hashq-ref)
108 "Search heirarchy of CLASS through the rmeta-slot named SLOT-NAME for
109 value matching KEY. This also calls maybe-build-rmeta-slot-cache! as a side
111 (maybe-build-rmeta-slot-cache! class slot-name
112 equals? cache-set! cache-ref)
113 (cache-ref (rmeta-slot-cache (class-slot-ref class slot-name)) key dflt))