/[meta-cvs]/meta-cvs/F-C31E700EDDDAF96042E6C4EBC25830C3.lisp
ViewVC logotype

Contents of /meta-cvs/F-C31E700EDDDAF96042E6C4EBC25830C3.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Fri Jun 28 13:50:01 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
Adding some cool code: a multi-hash datatype which implements
multi-dimensional sparse arrays using a tree of hash tables,
and a function memoizer which uses multi hash to index on
function arguments.

* multi-hash.lisp (multi-hash): New class.
(initialize-instance): New method on multi-hash.
(multi-hash-common-code): New macro.
(get-multi-hash, set-multi-hash): New functions.

* memoize.lisp (define-memoized-function,
memoized-labels): New macros.
(remove-key-aux-rest strip-lambda-list, extract-tests,
remove-tests, memoize-expander): New functions.

* seqfuncs.lisp (lcs-list): Function is now correctly
memoized using define-memoized-function.
1 kaz 1.1 ;;; This source file is part of the Meta-CVS program,
2     ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5     (require "multi-hash")
6     (provide "memoize")
7    
8     (eval-when (:compile-toplevel :load-toplevel)
9     (defun remove-key-aux-rest (lambda-list)
10     (cond
11     ((null lambda-list) nil)
12     ((member (first lambda-list) '(&rest &aux &key &body)) nil)
13     (t (cons (first lambda-list) (remove-key-aux-rest (rest lambda-list))))))
14    
15     (defun strip-lambda-list (list)
16     (labels ((simplify-var-form (form)
17     (cond
18     ((eq '&optional form) nil)
19     ((symbolp form) (list form))
20     ((consp form) (list (first form)))
21     (t (error "MEMOIZE-EXPANDER: bad thing in lambda list: ~a~%"
22     form)))))
23     (mapcan #'simplify-var-form (remove-key-aux-rest list))))
24    
25     (defun extract-tests (lambda-list)
26     (let ((saw-optional))
27     (mapcan #'(lambda (element)
28     (cond
29     ((eq '&optional element)
30     (setf saw-optional t)
31     nil)
32     ((consp element)
33     (if saw-optional
34     (destructuring-bind (var &optional init &key test) element
35     (declare (ignore var init))
36     (list (or test '#'eql)))
37     (destructuring-bind (var &key test) element
38     (declare (ignore var init))
39     (list (or test '#'eql)))))
40     (t (list '#'eql))))
41     (remove-key-aux-rest lambda-list))))
42    
43     (defun remove-tests (lambda-list)
44     (let (saw-optional saw-key)
45     (mapcar #'(lambda (element)
46     (cond
47     ((eq '&optional element)
48     (setf saw-optional t)
49     element)
50     ((eq '&key element)
51     (setf saw-key t)
52     element)
53     ((consp element)
54     (if saw-key
55     element
56     (if saw-optional
57     (destructuring-bind (var &optional init &key test) element
58     (declare (ignore test))
59     (append (list var) (if init (list init))))
60     (destructuring-bind (var &key test) element
61     (declare (ignore test))
62     var))))
63     (t element)))
64     lambda-list)))
65    
66     (defun memoize-expander (name lambda-list tests body expr)
67     (let ((multi-hash-sym (gensym "MULTI-HASH-"))
68     (hash-result-sym (gensym "HASH-RESULT-"))
69     (hash-found-sym (gensym "HASH-FOUND-")))
70     `(let ((,multi-hash-sym (make-instance 'multi-hash
71     :dimensions ,(length lambda-list)
72     :tests ,tests)))
73     (labels ((,name ,lambda-list
74     (multiple-value-bind (,hash-result-sym ,hash-found-sym)
75     (get-multi-hash ,multi-hash-sym
76     ,@lambda-list)
77     (if ,hash-found-sym
78     ,hash-result-sym
79     (setf (get-multi-hash ,multi-hash-sym ,@lambda-list)
80     (progn ,@body)))))) ,expr)))))
81    
82     (defmacro define-memoized-function (name lambda-list &body forms)
83     (let ((stripped-ll (strip-lambda-list lambda-list)))
84     `(defun ,name ,(remove-tests lambda-list)
85     ,(memoize-expander name stripped-ll `(list ,@(extract-tests lambda-list))
86     forms `(funcall #',name ,@stripped-ll)))))
87    
88     (defmacro memoized-labels (&rest memoized-labels-list)
89     `(labels ,(mapcar #'(lambda (labels)
90     (destructuring-bind (name lambda-list &body forms)
91     labels
92     (let ((stripped-ll (strip-lambda-list lambda-list)))
93     `(,name ,(remove-tests lambda-list)
94     ,(memoize-expander name stripped-ll
95     `(list ,@(extract-tests
96     lambda-list))
97     forms
98     `(funcall #',name
99     ,@stripped-ll))))))
100     memoized-labels-list)))

  ViewVC Help
Powered by ViewVC 1.1.5