+ (let ((lvar (nth (1- n) (combination-args call))))
+ (when (and lvar (constant-lvar-p lvar))
+ (careful-specifier-type (lvar-value lvar))))))
+
+;;; Derive the type to be the type specifier which is the Nth arg,
+;;; with the additional restriptions noted in the CLHS for STRING and
+;;; SIMPLE-STRING, defined to specialize on CHARACTER, and for VECTOR
+;;; (under the page for MAKE-SEQUENCE).
+(defun creation-result-type-specifier-nth-arg (n)
+ (lambda (call)
+ (declare (type combination call))
+ (let ((lvar (nth (1- n) (combination-args call))))
+ (when (and lvar (constant-lvar-p lvar))
+ (let* ((specifier (lvar-value lvar))
+ (lspecifier (if (atom specifier) (list specifier) specifier)))
+ (cond
+ ((eq (car lspecifier) 'string)
+ (destructuring-bind (string &rest size)
+ lspecifier
+ (declare (ignore string))
+ (careful-specifier-type
+ `(vector character ,@(when size size)))))
+ ((eq (car lspecifier) 'simple-string)
+ (destructuring-bind (simple-string &rest size)
+ lspecifier
+ (declare (ignore simple-string))
+ (careful-specifier-type
+ `(simple-array character ,@(if size (list size) '((*)))))))
+ (t
+ (let ((ctype (careful-specifier-type specifier)))
+ (if (and (array-type-p ctype)
+ (eq (array-type-specialized-element-type ctype)
+ *wild-type*))
+ ;; I don't think I'm allowed to modify what I get
+ ;; back from SPECIFIER-TYPE; it is, after all,
+ ;; cached. Better copy it, then.
+ (let ((real-ctype (copy-structure ctype)))
+ (setf (array-type-element-type real-ctype)
+ *universal-type*
+ (array-type-specialized-element-type real-ctype)
+ *universal-type*)
+ real-ctype)
+ ctype)))))))))
+
+(defun remove-non-constants-and-nils (fun)
+ (lambda (list)
+ (remove-if-not #'lvar-value
+ (remove-if-not #'constant-lvar-p (funcall fun list)))))
+
+;;; FIXME: bad name (first because it uses 1-based indexing; second
+;;; because it doesn't get the nth constant arguments)
+(defun nth-constant-args (&rest indices)
+ (lambda (list)
+ (let (result)
+ (do ((i 1 (1+ i))
+ (list list (cdr list))
+ (indices indices))
+ ((null indices) (nreverse result))
+ (when (= i (car indices))
+ (when (constant-lvar-p (car list))
+ (push (car list) result))
+ (setf indices (cdr indices)))))))
+
+;;; FIXME: a number of the sequence functions not only do not destroy
+;;; their argument if it is empty, but also leave it alone if :start
+;;; and :end bound a null sequence, or if :count is 0. This test is a
+;;; bit complicated to implement, verging on the impossible, but for
+;;; extra points (fill #\1 "abc" :start 0 :end 0) should not cause a
+;;; warning.
+(defun nth-constant-nonempty-sequence-args (&rest indices)
+ (lambda (list)
+ (let (result)
+ (do ((i 1 (1+ i))
+ (list list (cdr list))
+ (indices indices))
+ ((null indices) (nreverse result))
+ (when (= i (car indices))
+ (when (constant-lvar-p (car list))
+ (let ((value (lvar-value (car list))))
+ (unless (or (typep value 'null)
+ (typep value '(vector * 0)))
+ (push (car list) result))))
+ (setf indices (cdr indices)))))))