From 5145dd3aa0c02c9fc496d1432fc4410674206e1d Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:31 -0800 Subject: Import Upstream version 3a2 --- dbinterp.scm | 42 ++++++++++++++++++++++++++++++------------ 1 file changed, 30 insertions(+), 12 deletions(-) (limited to 'dbinterp.scm') 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)) -- cgit v1.2.3