147 |
(let ((walk-form-expand-macros-p t)) |
(let ((walk-form-expand-macros-p t)) |
148 |
(walk-form lambda |
(walk-form lambda |
149 |
nil |
nil |
150 |
#'(lambda (f c e) |
(lambda (f c e) |
151 |
(declare (ignore e)) |
(declare (ignore e)) |
152 |
(if (neq c :eval) |
(if (neq c :eval) |
153 |
f |
f |
159 |
(gensyms ())) |
(gensyms ())) |
160 |
(values (walk-form lambda |
(values (walk-form lambda |
161 |
nil |
nil |
162 |
#'(lambda (f c e) |
(lambda (f c e) |
163 |
(declare (ignore e)) |
(declare (ignore e)) |
164 |
(if (neq c :eval) |
(if (neq c :eval) |
165 |
f |
f |
170 |
gensyms))) |
gensyms))) |
171 |
|
|
172 |
(defun compute-constants (lambda constant-converter) |
(defun compute-constants (lambda constant-converter) |
173 |
(let ((walk-form-expand-macros-p t)) ; doesn't matter here. |
(let ((walk-form-expand-macros-p t) ; doesn't matter here. |
174 |
(macrolet ((appending () |
(collected ())) |
175 |
`(let ((result ())) |
(walk-form lambda |
176 |
(values #'(lambda (value) (setq result (append result value))) |
nil |
177 |
#'(lambda ()result))))) |
(lambda (f c e) |
178 |
(gathering1 (appending) |
(declare (ignore e)) |
179 |
(walk-form lambda |
(if (eq c :eval) |
180 |
nil |
(let ((consts (funcall constant-converter f))) |
181 |
#'(lambda (f c e) |
(if consts |
182 |
(declare (ignore e)) |
(progn |
183 |
(if (neq c :eval) |
(setq collected (append collected consts)) |
184 |
f |
(values f t)) |
185 |
(let ((consts (funcall constant-converter f))) |
f)) |
186 |
(if consts |
f))) |
187 |
(progn (gather1 consts) (values f t)) |
collected)) |
|
f))))))))) |
|
|
|
|
|
|
|
188 |
;;; |
;;; |
189 |
;;; |
;;; |
190 |
;;; |
;;; |
191 |
(defmacro precompile-function-generators (&optional system) |
(defmacro precompile-function-generators (&optional system) |
192 |
(let ((index -1)) |
(let ((index -1)) |
193 |
`(progn ,@(gathering1 (collecting) |
`(progn ,@(let ((collected ())) |
194 |
(dolist (fgen *fgens*) |
(dolist (fgen *fgens* (nreverse collected)) |
195 |
(when (or (null (fgen-system fgen)) |
(when (or (null (fgen-system fgen)) |
196 |
(eq (fgen-system fgen) system)) |
(eq (fgen-system fgen) system)) |
197 |
(when system (setf (svref fgen 4) system)) |
(when system |
198 |
(gather1 |
(setf (svref fgen 4) system)) |
199 |
|
(push |
200 |
(make-top-level-form |
(make-top-level-form |
201 |
`(precompile-function-generators ,system ,(incf index)) |
`(precompile-function-generators ,system ,(incf index)) |
202 |
'(load) |
'(load) |
205 |
',(fgen-gensyms fgen) |
',(fgen-gensyms fgen) |
206 |
(function ,(fgen-generator-lambda fgen)) |
(function ,(fgen-generator-lambda fgen)) |
207 |
',(fgen-generator-lambda fgen) |
',(fgen-generator-lambda fgen) |
208 |
',system))))))))) |
',system)) |
209 |
|
collected))))))) |
210 |
|
|
211 |
(defun load-function-generator (test gensyms generator generator-lambda system) |
(defun load-function-generator (test gensyms generator generator-lambda system) |
212 |
(store-fgen (make-fgen test gensyms generator generator-lambda system))) |
(store-fgen (make-fgen test gensyms generator generator-lambda system))) |