blob: bb786e90de9b831011c13a6fa82fe8dbe0bffa44 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; Commentary:
;;
;; Slots whose values can be lazily recomputed.
;;
;;; Code:
(define-module (catbird cached-slots)
#:use-module (catbird config)
#:use-module (oop goops)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:export (<cacheable>
slot-expired?
expire-slot!))
(define-record-type <cached-value>
(%make-cached-value value expired? proc)
cached-value?
(value %cached-value-ref set-cached-value!)
(expired? cached-value-expired? set-cached-value-expired!)
(proc cached-value-proc))
(define (make-cached-value init proc)
(%make-cached-value init #t proc))
(define (refresh-cached-value! cache)
(let ((x ((cached-value-proc cache) (%cached-value-ref cache))))
(set-cached-value! cache x)
(set-cached-value-expired! cache #f)))
(define (cached-value-ref cache)
(when (cached-value-expired? cache)
(refresh-cached-value! cache))
(%cached-value-ref cache))
(define (expire-cached-value! cache)
(set-cached-value-expired! cache #t))
(define (expire-slot! obj slot-name)
(expire-cached-value! (slot-ref obj slot-name)))
(define (slot-expired? obj slot-name)
(cached-value-expired? (slot-ref obj slot-name)))
(define-class <cached-slot-class> (<catbird-metaclass>))
(define (slot-ref* obj slot-name)
(and (slot-bound? obj slot-name)
(slot-ref obj slot-name)))
(define-method (cached-slot? (slot <slot>))
(get-keyword #:cached? (slot-definition-options slot)))
(define-method (slot-refresh-proc (slot <slot>))
(get-keyword #:refresh (slot-definition-options slot)))
(define-method (compute-getter-method (class <cached-slot-class>) slot)
(if (cached-slot? slot)
;; Wrap the original getter procedure with a new procedure that
;; extracts the current value from the cached value, recomputing
;; it if necessary.
(make <method>
#:specializers (list class)
#:procedure (let ((proc (method-procedure (next-method))))
(lambda (obj)
(cached-value-ref (proc obj)))))
(next-method)))
(define-method (compute-setter-method (class <cached-slot-class>) slot)
(if (cached-slot? slot)
(make <method>
#:specializers (list class <top>)
#:procedure (lambda (obj new)
(raise-exception
(make-exception-with-message "cached slots cannot be set"))))
(next-method)))
(define-class <cacheable> ()
#:metaclass <cached-slot-class>)
(define-method (initialize (instance <cacheable>) initargs)
(next-method)
;; Setup cached values.
(for-each (lambda (slot)
(when (cached-slot? slot)
(let* ((slot-name (slot-definition-name slot))
(refresh-proc (slot-refresh-proc slot))
(cached-value (make-cached-value
(slot-ref* instance slot-name)
(lambda (prev)
(refresh-proc instance prev)))))
(slot-set! instance slot-name cached-value))))
(class-slots (class-of instance))))
|
