ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by kaz, Thu Oct 31 04:06:01 2002 UTC revision 1.5 by kaz, Wed Feb 12 07:02:13 2003 UTC
# Line 10  Line 10 
11  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
12    (defun remove-key-aux-rest (lambda-list)    (defun remove-key-aux-rest (lambda-list)
13    "Remove any trailing portion of the lambda list that starts with
14    one of the lambda list keywords &rest, &key, &aux or &body."
15      (cond      (cond
16        ((null lambda-list) nil)        ((null lambda-list) nil)
17        ((member (first lambda-list) '(&rest &aux &key &body)) nil)        ((member (first lambda-list) '(&rest &aux &key &body)) nil)
18        (t (cons (first lambda-list) (remove-key-aux-rest (rest lambda-list))))))        (t (cons (first lambda-list) (remove-key-aux-rest (rest lambda-list))))))
20    (defun strip-lambda-list (list)    (defun strip-lambda-list (list)
21    "Simplify a lambda list by removing occurences of &optional, stripping
22    away the trailing portion using REMOVE-KEY-AUX-REST, canonicalizing
23    simple variable forms to lists so that SYMBOL becomes (SYMBOL), and removing
24    initializers so that (SYMBOL INITFORM) becomes (SYMBOL). This stripped
25    lambda list becomes the lambda list of the hidden inner function that
26    implements the guts of a memoized function, and captures the recursive
27    calls. The &OPTIONAL parameters are reduced to required ones, and there
28    are no trailing &KEY or &rest parameters."
29      (labels ((simplify-var-form (form)      (labels ((simplify-var-form (form)
30                 (cond                 (cond
31                   ((eq '&optional form) nil)                   ((eq '&optional form) nil)
# Line 26  Line 36 
36        (mapcan #'simplify-var-form (remove-key-aux-rest list))))        (mapcan #'simplify-var-form (remove-key-aux-rest list))))
38    (defun extract-tests (lambda-list)    (defun extract-tests (lambda-list)
39    "The memoize module understands special lambda lists which, as an extension
40    to regular Lisp lambda lists, allow the programmer to specify what test
41    function should be used for the hash table used to memoize over a given
42    parameter. This function parses such a lambda list and extracts the tests.
43    The subtlety here is that after the &optional keyword, the syntax changes.
44    For required parameters, the syntax which specifies the test is
45    (SYMBOL :TEST FUNCTION). For &optional paramters, the syntax becomes
46    (SYMBOL INITFORM :TEST FUNCTION). For any variable which doesn't specify
47    a test, the test is assumed to be #'eql."
48      (let ((saw-optional))      (let ((saw-optional))
49        (mapcan #'(lambda (element)        (mapcan #'(lambda (element)
50                    (cond                    (cond
# Line 44  Line 63 
63                (remove-key-aux-rest lambda-list))))                (remove-key-aux-rest lambda-list))))
65    (defun remove-tests (lambda-list)    (defun remove-tests (lambda-list)
66    "This function removes the :test specifications from a the memoized
67    function lambda list, thereby reducing it to a regular lambda list.
68    See the docstring for EXTRACT-TESTS for a little more information.
69    We need to do this to generate the outer shell of the memoized function,
70    which is a normal Lisp function."
71      (let (saw-optional saw-key)      (let (saw-optional saw-key)
72        (mapcar #'(lambda (element)        (mapcar #'(lambda (element)
73                    (cond                    (cond
# Line 67  Line 91 
91                lambda-list)))                lambda-list)))
93  (defun memoize-expander (name lambda-list tests body expr)  (defun memoize-expander (name lambda-list tests body expr)
94    "Produce a memoized function in the form of a LABELS function that is
95    wrapped in a LET block. The LET block sets up the hash table, either
96    a regular hash table if there is one paramter, or a MULTI-HASH if
97    there are several parameters.  The body of the LABELS performs the
98    memoization stuff with the hash tables. Note that the function
99    FACTOR-MEMO-LABELS depends on this structure of the LABELS nested
100    within the LET."
101    (let ((multi-hash-sym (gensym "MULTI-HASH-"))    (let ((multi-hash-sym (gensym "MULTI-HASH-"))
102          (hash-result-sym (gensym "HASH-RESULT-"))          (hash-result-sym (gensym "HASH-RESULT-"))
103          (hash-found-sym (gensym "HASH-FOUND-"))          (hash-found-sym (gensym "HASH-FOUND-"))
# Line 91  Line 122 
122                              (progn ,@body)))))) ,expr))))                              (progn ,@body)))))) ,expr))))
124  (defun factor-memo-labels (memo-labels forms)  (defun factor-memo-labels (memo-labels forms)
125    "This function takes a list of the LET expressions, each of which is assumed to
126    be generated by MEMOIZE-EXPANDER, and factors them out to produce one giant
127    LET block with all of the LET material (hash tables) coalesced together,
128    enclosing one big coalesced LABELS block that defines all of the functions
129    together. This trick allows us to generate individual memoized inner functions
130    using MEMOIZE-EXPANDER, and then fuse them together to make one big
131    party of mutually recursive memoized functions."
132    (macrolet ((destructure-memo-labels (labels &body labels-forms)    (macrolet ((destructure-memo-labels (labels &body labels-forms)
133                 `(destructuring-bind (name outer-lambda                 `(destructuring-bind (name outer-lambda
134                                        (let inner-lambda &rest labels-forms))                                        (let inner-lambda &rest labels-forms))
135                                      ,labels ,@labels-forms)))                                      ,labels
136                      (declare (ignorable name outer-lambda let inner-lambda
137                                          labels-forms))
138                      ,@labels-forms)))
139      (flet ((extract-lets (labels)      (flet ((extract-lets (labels)
140               (destructure-memo-labels labels               (destructure-memo-labels labels
                (declare (ignore let name outer-lambda labels-forms))  
141                 inner-lambda))                 inner-lambda))
142             (extract-funcs (labels)             (extract-funcs (labels)
143               (destructure-memo-labels labels               (destructure-memo-labels labels
                (declare (ignore let inner-lambda))  
144                 `(,name ,outer-lambda ,@labels-forms))))                 `(,name ,outer-lambda ,@labels-forms))))
145        `(let ,(mapcan #'extract-lets memo-labels)        `(let ,(mapcan #'extract-lets memo-labels)
146           (labels ,(mapcar #'extract-funcs memo-labels) ,@forms))))))           (labels ,(mapcar #'extract-funcs memo-labels) ,@forms))))))
148  (defmacro define-memoized-function (name lambda-list &body forms)  (defmacro define-memoized-function (name lambda-list &body forms)
149    "Generate a DEFUN definition for a function called NAME, placing the
150    body into an inner recursive function of the same name that is memoized.
151    Effectively, this creates a memoized function: one whose recursive calls
152    are automatically cached using the parameter lists as keys into a multi-level
153    hash table. This is an important optimization technique when the recursion
154    contains overlapping cases; it can reduce exponential time to polynomial time.
155    This macro understands a special lambda list syntax. A required parameter
156    normally written as SYMBOL can be written (SYMBOL :TEST FUNC) to specify a
157    hashing equality function FUNC for that parameter which can be #'EQ,
158    #'EQL, #'EQUAL or #'EQUALP. For an optional parameter, this syntax is
159    (SYMBOL INIT-FORM :TEST FUNC). Note that only the outer function accepts
160    &KEY and &REST parameters, if any are specified. The inner recursive memoized
161    function does not; it has a simplified lambda list."
162    (let ((stripped-ll (strip-lambda-list lambda-list)))    (let ((stripped-ll (strip-lambda-list lambda-list)))
163      `(defun ,name ,(remove-tests lambda-list)      `(defun ,name ,(remove-tests lambda-list)
164         ,(memoize-expander name stripped-ll `(list ,@(extract-tests lambda-list))         ,(memoize-expander name stripped-ll `(list ,@(extract-tests lambda-list))
165                            forms `(,name ,@stripped-ll)))))                            forms `(,name ,@stripped-ll)))))
167  (defmacro memoized-labels ((&rest memoized-labels-list) &body forms)  (defmacro memoized-labels ((&rest memoized-labels-list) &body forms)
168    "Generate a block of mutually recursive LABELS functions, making the
169    DEFINE-MEMOIZED-FUNCTION utility available for local functions. See
170    the documentation string for that macro for more details."
171    (flet ((generate-labels-element (labels)    (flet ((generate-labels-element (labels)
172             (destructuring-bind (name lambda-list &body labels-forms) labels             (destructuring-bind (name lambda-list &body labels-forms) labels
173               (let ((stripped-ll (strip-lambda-list lambda-list)))               (let ((stripped-ll (strip-lambda-list lambda-list)))

Removed from v.1.4  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5