/[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.4 - (show annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.3: +3 -0 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

* code/install.sh: Generate mcvs script that uses qualified name
of new startup functiont to start the software.
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 (require "mcvs-package")
7 (provide "memoize")
8
9 (in-package "META-CVS")
10
11 (eval-when (:compile-toplevel :load-toplevel :execute)
12 (defun remove-key-aux-rest (lambda-list)
13 (cond
14 ((null lambda-list) nil)
15 ((member (first lambda-list) '(&rest &aux &key &body)) nil)
16 (t (cons (first lambda-list) (remove-key-aux-rest (rest lambda-list))))))
17
18 (defun strip-lambda-list (list)
19 (labels ((simplify-var-form (form)
20 (cond
21 ((eq '&optional form) nil)
22 ((symbolp form) (list form))
23 ((consp form) (list (first form)))
24 (t (error "MEMOIZE-EXPANDER: bad thing in lambda list: ~a~%"
25 form)))))
26 (mapcan #'simplify-var-form (remove-key-aux-rest list))))
27
28 (defun extract-tests (lambda-list)
29 (let ((saw-optional))
30 (mapcan #'(lambda (element)
31 (cond
32 ((eq '&optional element)
33 (setf saw-optional t)
34 nil)
35 ((consp element)
36 (if saw-optional
37 (destructuring-bind (var &optional init &key test) element
38 (declare (ignore var init))
39 (list (or test '#'eql)))
40 (destructuring-bind (var &key test) element
41 (declare (ignore var init))
42 (list (or test '#'eql)))))
43 (t (list '#'eql))))
44 (remove-key-aux-rest lambda-list))))
45
46 (defun remove-tests (lambda-list)
47 (let (saw-optional saw-key)
48 (mapcar #'(lambda (element)
49 (cond
50 ((eq '&optional element)
51 (setf saw-optional t)
52 element)
53 ((eq '&key element)
54 (setf saw-key t)
55 element)
56 ((consp element)
57 (if saw-key
58 element
59 (if saw-optional
60 (destructuring-bind (var &optional init &key test) element
61 (declare (ignore test))
62 (append (list var) (if init (list init))))
63 (destructuring-bind (var &key test) element
64 (declare (ignore test))
65 var))))
66 (t element)))
67 lambda-list)))
68
69 (defun memoize-expander (name lambda-list tests body expr)
70 (let ((multi-hash-sym (gensym "MULTI-HASH-"))
71 (hash-result-sym (gensym "HASH-RESULT-"))
72 (hash-found-sym (gensym "HASH-FOUND-"))
73 (dimensions (length lambda-list)))
74 `(let ((,multi-hash-sym ,(if (> dimensions 1)
75 `(make-instance 'multi-hash
76 :dimensions ,dimensions
77 :tests ,tests)
78 `(make-hash-table :test ,(second tests)))))
79 (labels ((,name ,lambda-list
80 (multiple-value-bind (,hash-result-sym ,hash-found-sym)
81 ,(if (> dimensions 1)
82 `(get-multi-hash ,multi-hash-sym
83 ,@lambda-list)
84 `(gethash ,@lambda-list
85 ,multi-hash-sym))
86 (if ,hash-found-sym
87 ,hash-result-sym
88 (setf ,(if (> dimensions 1)
89 `(get-multi-hash ,multi-hash-sym ,@lambda-list)
90 `(gethash ,@lambda-list ,multi-hash-sym))
91 (progn ,@body)))))) ,expr))))
92
93 (defun factor-memo-labels (memo-labels forms)
94 (macrolet ((destructure-memo-labels (labels &body labels-forms)
95 `(destructuring-bind (name outer-lambda
96 (let inner-lambda &rest labels-forms))
97 ,labels ,@labels-forms)))
98 (flet ((extract-lets (labels)
99 (destructure-memo-labels labels
100 (declare (ignore let name outer-lambda labels-forms))
101 inner-lambda))
102 (extract-funcs (labels)
103 (destructure-memo-labels labels
104 (declare (ignore let inner-lambda))
105 `(,name ,outer-lambda ,@labels-forms))))
106 `(let ,(mapcan #'extract-lets memo-labels)
107 (labels ,(mapcar #'extract-funcs memo-labels) ,@forms))))))
108
109 (defmacro define-memoized-function (name lambda-list &body forms)
110 (let ((stripped-ll (strip-lambda-list lambda-list)))
111 `(defun ,name ,(remove-tests lambda-list)
112 ,(memoize-expander name stripped-ll `(list ,@(extract-tests lambda-list))
113 forms `(,name ,@stripped-ll)))))
114
115 (defmacro memoized-labels ((&rest memoized-labels-list) &body forms)
116 (flet ((generate-labels-element (labels)
117 (destructuring-bind (name lambda-list &body labels-forms) labels
118 (let ((stripped-ll (strip-lambda-list lambda-list)))
119 `(,name ,(remove-tests lambda-list)
120 ,(memoize-expander name stripped-ll
121 `(list ,@(extract-tests lambda-list))
122 labels-forms
123 `(,name ,@stripped-ll)))))))
124 (factor-memo-labels (mapcar #'generate-labels-element
125 memoized-labels-list) forms)))

  ViewVC Help
Powered by ViewVC 1.1.5