Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | ;;; installed-scm-file |
2 | ||
cd5fea8d | 3 | ;;;; Copyright (C) 1996, 2001, 2006 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 | ||
77 | ||
1a179b03 | 78 | (define (pure-funcq base-func) |
0f2d19dd JB |
79 | (lambda args |
80 | (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args)))) | |
81 | (if cached | |
82 | (begin | |
83 | (funcq-buffer (car cached)) | |
84 | (cdr cached)) | |
85 | ||
86 | (let ((val (apply base-func args)) | |
87 | (key (cons base-func args))) | |
88 | (funcq-buffer key) | |
89 | (hashx-set! funcq-hash funcq-assoc funcq-memo key val) | |
90 | val))))) | |
91 | ||
92 | \f | |
93 | ||
94 | ;;; {Perfect funq} | |
95 | ;;; | |
96 | ;;; A pure funq may sometimes forget its past but a perfect | |
97 | ;;; funcq never does. | |
98 | ;;; | |
99 | ||
1a179b03 | 100 | (define (perfect-funcq size base-func) |
0f2d19dd JB |
101 | (define funcq-memo (make-hash-table size)) |
102 | ||
103 | (lambda args | |
104 | (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args)))) | |
105 | (if cached | |
106 | (begin | |
107 | (funcq-buffer (car cached)) | |
108 | (cdr cached)) | |
109 | ||
110 | (let ((val (apply base-func args)) | |
111 | (key (cons base-func args))) | |
112 | (funcq-buffer key) | |
113 | (hashx-set! funcq-hash funcq-assoc funcq-memo key val) | |
114 | val))))) | |
115 | ||
116 | ||
117 | ||
118 | ||
119 | ||
120 | ||
121 | ||
122 |