Import Upstream version 3a2upstream/3a2

1 files changed, 30 insertions, 12 deletions

diff --git a/dbinterp.scm b/dbinterp.scm
index 8ccb1df..2bd4e20 100644
--- a/dbinterp.scm
+++ b/dbinterp.scm
@@ -17,18 +17,36 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
+(require 'rev4-optional-procedures)	; list-tail
+
+;;; The procedures returned by MEMOIZE are not reentrant!
+(define (dbinterp:memoize proc k)
+  (define recent (vector->list (make-vector k '(#f))))
+  (let ((tailr (list-tail recent (+ -1 k))))
+    (lambda args
+      (define asp (assoc args recent))
+      (if asp
+	  (cdr asp)
+	  (let ((val (apply proc args)))
+	    (set-cdr! tailr (list (cons args val)))
+	    (set! tailr (cdr tailr))
+	    (set! recent (cdr recent))
+	    val)))))
+
 ;;@ This procedure works only for tables with a single primary key.
 (define (interpolate-from-table table column)
-  (define get (table 'get column))
-  (define prev (table 'isam-prev))
+  (define get  (dbinterp:memoize (table 'get column) 3))
+  (define prev (dbinterp:memoize (table 'isam-prev) 3))
   (define next (table 'isam-next))
-  (lambda (x)
-    (let ((nxt (next x)))
-      (if nxt (set! nxt (car nxt)))
-      (let ((prv (prev (or nxt x))))
-	(if prv (set! prv (car prv)))
-	(cond ((not nxt) (get prv))
-	      ((not prv) (get nxt))
-	      (else (/ (+ (* (- x prv) (get nxt))
-			  (* (- nxt x) (get prv)))
-		       (- nxt prv))))))))
+  (dbinterp:memoize
+   (lambda (x)
+     (let ((nxt (next x)))
+       (if nxt (set! nxt (car nxt)))
+       (let ((prv (prev (or nxt x))))
+	 (if prv (set! prv (car prv)))
+	 (cond ((not nxt) (get prv))
+	       ((not prv) (get nxt))
+	       (else (/ (+ (* (- x prv) (get nxt))
+			   (* (- nxt x) (get prv)))
+			(- nxt prv)))))))
+   3))