;;; There are three internal functions which operate on the lambda argument
;;; to GET-FUNCTION:
;;; compute-test converts the lambda into a key to be used for lookup,
-;;; compute-code is used by get-new-function-generator-internal to
+;;; compute-code is used by get-new-fun-generator-internal to
;;; generate the actual lambda to be compiled, and
;;; compute-constants is used to generate the argument list that is
;;; to be passed to the compiled function.
(fgen (lookup-fgen test)))
(if fgen
(fgen-generator fgen)
- (get-new-function-generator lambda test code-converter))))
+ (get-new-fun-generator lambda test code-converter))))
-(defun get-new-function-generator (lambda test code-converter)
+(defun get-new-fun-generator (lambda test code-converter)
(multiple-value-bind (gensyms generator-lambda)
- (get-new-function-generator-internal lambda code-converter)
+ (get-new-fun-generator-internal lambda code-converter)
(let* ((generator (compile nil generator-lambda))
(fgen (make-fgen test gensyms generator generator-lambda nil)))
(store-fgen fgen)
generator)))
-(defun get-new-function-generator-internal (lambda code-converter)
+(defun get-new-fun-generator-internal (lambda code-converter)
(multiple-value-bind (code gensyms)
(compute-code lambda code-converter)
(values gensyms `(lambda ,gensyms (function ,code)))))
gensyms)))
(defun compute-constants (lambda constant-converter)
- (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
- (macrolet ((appending ()
- `(let ((result ()))
- (values #'(lambda (value) (setq result (append result value)))
- #'(lambda ()result)))))
- (gathering1 (appending)
- (walk-form lambda
- nil
- #'(lambda (f c e)
- (declare (ignore e))
- (if (neq c :eval)
- f
- (let ((consts (funcall constant-converter f)))
- (if consts
- (progn (gather1 consts) (values f t))
- f)))))))))
+ (let ((*walk-form-expand-macros-p* t) ; doesn't matter here.
+ collect)
+ (walk-form lambda
+ nil
+ #'(lambda (f c e)
+ (declare (ignore e))
+ (if (neq c :eval)
+ f
+ (let ((consts (funcall constant-converter f)))
+ (if consts
+ (progn
+ (setq collect (nconc collect consts))
+ (values f t))
+ f)))))
+ collect))
\f
(defmacro precompile-function-generators (&optional system)
`(progn
- ,@(gathering1 (collecting)
- (dolist (fgen *fgens*)
- (when (or (null (fgen-system fgen))
- (eq (fgen-system fgen) system))
- (when system (setf (svref fgen 4) system))
- (gather1
- `(load-function-generator
- ',(fgen-test fgen)
- ',(fgen-gensyms fgen)
- (function ,(fgen-generator-lambda fgen))
- ',(fgen-generator-lambda fgen)
- ',system)))))))
+ ,@(let (collect)
+ (dolist (fgen *fgens*)
+ (when (or (null (fgen-system fgen))
+ (eq (fgen-system fgen) system))
+ (when system (setf (svref fgen 4) system))
+ (push `(load-function-generator
+ ',(fgen-test fgen)
+ ',(fgen-gensyms fgen)
+ (function ,(fgen-generator-lambda fgen))
+ ',(fgen-generator-lambda fgen)
+ ',system)
+ collect)))
+ (nreverse collect))))
(defun load-function-generator (test gensyms generator generator-lambda system)
(store-fgen (make-fgen test gensyms generator generator-lambda system)))