- `(,function ,first-arg ,arg)
- (associate-args function `(,function ,first-arg ,arg) next))))
+ `(,fun ,first-arg ,(if arg arg identity))
+ (associate-args fun `(,fun ,first-arg ,arg) next identity))))
+
+;;; Reduce constants in ARGS list.
+(declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants))
+(defun reduce-constants (fun args identity one-arg-result-type)
+ (let ((one-arg-constant-p (ecase one-arg-result-type
+ (number #'numberp)
+ (integer #'integerp)))
+ (reduced-value identity)
+ (reduced-p nil))
+ (collect ((not-constants))
+ (dolist (arg args)
+ (if (funcall one-arg-constant-p arg)
+ (setf reduced-value (funcall fun reduced-value arg)
+ reduced-p t)
+ (not-constants arg)))
+ ;; It is tempting to drop constants reduced to identity here,
+ ;; but if X is SNaN in (* X 1), we cannot drop the 1.
+ (if (not-constants)
+ (if reduced-p
+ `(,reduced-value ,@(not-constants))
+ (not-constants))
+ `(,reduced-value)))))