Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | ;;; installed-scm-file |
2 | ||
8bee35bc | 3 | ;;;; Copyright (C) 1996, 2001, 2006, 2011 Free Software Foundation, Inc. |
0f2d19dd | 4 | ;;;; |
73be1d9e MV |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
0f2d19dd | 9 | ;;;; |
73be1d9e | 10 | ;;;; This library is distributed in the hope that it will be useful, |
0f2d19dd | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
0f2d19dd | 14 | ;;;; |
73be1d9e MV |
15 | ;;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
0f2d19dd JB |
18 | ;;;; |
19 | ||
20 | \f | |
8bb7330c | 21 | (define-module (ice-9 poe) |
1a179b03 MD |
22 | :use-module (ice-9 hcons) |
23 | :export (pure-funcq perfect-funcq)) | |
0f2d19dd JB |
24 | |
25 | \f | |
26 | ||
27 | ||
28 | ;;; {Pure Functions} | |
29 | ;;; | |
30 | ;;; A pure function (of some sort) is characterized by two equality | |
31 | ;;; relations: one on argument lists and one on return values. | |
32 | ;;; A pure function is one that when applied to equal arguments lists | |
33 | ;;; yields equal results. | |
34 | ;;; | |
35 | ;;; If the equality relationship on return values can be eq?, it may make | |
36 | ;;; sense to cache values returned by the function. Choosing the right | |
37 | ;;; equality relation on arguments is tricky. | |
38 | ;;; | |
39 | ||
40 | \f | |
41 | ;;; {pure-funcq} | |
42 | ;;; | |
43 | ;;; The simplest case of pure functions are those in which results | |
44 | ;;; are only certainly eq? if all of the arguments are. These functions | |
45 | ;;; are called "pure-funcq", for obvious reasons. | |
46 | ;;; | |
47 | ||
48 | ||
ea7715eb | 49 | (define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values |
0f2d19dd JB |
50 | (define funcq-buffer (make-gc-buffer 256)) |
51 | ||
52 | (define (funcq-hash arg-list n) | |
53 | (let ((it (let loop ((x 0) | |
54 | (arg-list arg-list)) | |
55 | (if (null? arg-list) | |
56 | (modulo x n) | |
57 | (loop (logior x (hashq (car arg-list) 4194303)) | |
58 | (cdr arg-list)))))) | |
59 | it)) | |
60 | ||
d6532dd1 KR |
61 | ;; return true if lists X and Y are the same length and each element is `eq?' |
62 | (define (eq?-list x y) | |
63 | (if (null? x) | |
64 | (null? y) | |
65 | (and (not (null? y)) | |
66 | (eq? (car x) (car y)) | |
67 | (eq?-list (cdr x) (cdr y))))) | |
68 | ||
0f2d19dd | 69 | (define (funcq-assoc arg-list alist) |
d6532dd1 KR |
70 | (if (null? alist) |
71 | #f | |
72 | (if (eq?-list arg-list (caar alist)) | |
73 | (car alist) | |
74 | (funcq-assoc arg-list (cdr alist))))) | |
0f2d19dd JB |
75 | |
76 | ||
8bee35bc AW |
77 | (define not-found (list 'not-found)) |
78 | ||
0f2d19dd | 79 | |
1a179b03 | 80 | (define (pure-funcq base-func) |
0f2d19dd | 81 | (lambda args |
8bee35bc AW |
82 | (let* ((key (cons base-func args)) |
83 | (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found))) | |
84 | (if (not (eq? cached not-found)) | |
0f2d19dd | 85 | (begin |
8bee35bc AW |
86 | (funcq-buffer key) |
87 | cached) | |
0f2d19dd | 88 | |
8bee35bc | 89 | (let ((val (apply base-func args))) |
0f2d19dd JB |
90 | (funcq-buffer key) |
91 | (hashx-set! funcq-hash funcq-assoc funcq-memo key val) | |
92 | val))))) | |
93 | ||
94 | \f | |
95 | ||
96 | ;;; {Perfect funq} | |
97 | ;;; | |
98 | ;;; A pure funq may sometimes forget its past but a perfect | |
99 | ;;; funcq never does. | |
100 | ;;; | |
101 | ||
1a179b03 | 102 | (define (perfect-funcq size base-func) |
0f2d19dd JB |
103 | (define funcq-memo (make-hash-table size)) |
104 | ||
105 | (lambda args | |
8bee35bc AW |
106 | (let* ((key (cons base-func args)) |
107 | (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found))) | |
108 | (if (not (eq? cached not-found)) | |
0f2d19dd | 109 | (begin |
8bee35bc AW |
110 | (funcq-buffer key) |
111 | cached) | |
0f2d19dd | 112 | |
8bee35bc | 113 | (let ((val (apply base-func args))) |
0f2d19dd JB |
114 | (funcq-buffer key) |
115 | (hashx-set! funcq-hash funcq-assoc funcq-memo key val) | |
116 | val))))) |