Type Declaration Propagating DEFINE-MODIFY-MACRO for INCF and DECF that play nice with CLTL2

cltl2-define-modify-macro.lisp

(defun macroexpand-until (predicate form &optional env)
  "Calls MACROEXPAND-1 on FORM until it is (FUNCALL PREDICATE FORM) returns non-NIL"
  (loop :until (funcall predicate form)
        :for expansion := (macroexpand-1 form env)
        :do (setq form expansion)
        :finally (return form)))

(defun macroexpand-until-car (car form &optional env)
  "Calls MACROEXPAND-1 on FORM until it is a list which
starts with the symbol specified by CAR"
  (cl:check-type car symbol)
  (loop :until (and (listp form)
                    (eq car (car form)))
        :for expansion := (macroexpand-1 form env)
        :do (setq form expansion)
        :finally (return form)))

(defun type-decl-from-bindings (bindings env &key parallel)
  (if parallel
      (loop :for binding :in bindings
            :nconcing
            (multiple-value-bind (var form)
                (if (symbolp binding)
                    (values binding nil)
                    (values-list binding))
              (unless
                  #+sbcl (and (symbol-package var)
                              (sb-ext:package-locked-p (symbol-package var)))
                  #-sbcl ()
                  (let ((form-type (cl-form-types:nth-form-type form env 0 t #-ccl t
                                                                             #+ccl nil)))
                    (cond ((eq cl:t form-type)
                           ())
                          (t
                           `((ex:extype ,form-type ,var)
                             (cl:type ,(ex:upgraded-cl-type form-type env) ,var))))))))
      (loop :with augmented-env := nil
            :with form-type-env := env
            :for binding :in bindings
            :nconcing
            (multiple-value-bind (var form)
                (if (symbolp binding)
                    (values binding nil)
                    (values-list binding))
              (unless #+sbcl (and (symbol-package var)
                                  (sb-ext:package-locked-p (symbol-package var)))
                      #-sbcl ()
                      (let ((form-type (cl-form-types:nth-form-type
                                        form form-type-env 0 t #-ccl t #+ccl nil)))
                        (cond ((eq cl:t form-type)
                               ())
                              (t
                               (let ((decl
                                       `((ex:extype ,form-type ,var)
                                         (cl:type ,(ex:upgraded-cl-type
                                                    form-type form-type-env)
                                                  ,var))))
                                 (setq augmented-env
                                       (augment-environment
                                        augmented-env
                                        :variable (list var)
                                        :declare decl))
                                 (setq form-type-env
                                       (augment-environment
                                        form-type-env
                                        :variable (list var)
                                        :declare decl))
                                 decl)))))))))
                                 
(defmacro excl:define-modify-macro (name lambda-list function &optional doc-string)
  (optima:ematch (macroexpand-until-car 'cl:defmacro
                                        `(cl-environments-cl:define-modify-macro
                                             ,name ,lambda-list ,function ,doc-string))
    ((list* 'cl:defmacro name lambda-list body)
     (alexandria:with-gensyms (expr bindings let-body form)
       (multiple-value-bind (lambda-list env-sym)
           (let ((env-pos (position '&environment lambda-list)))
             (if env-pos
                 (values lambda-list (nth (1+ env-pos) lambda-list))
                 (let ((env-sym (gensym "ENV")))
                   (values (nconc lambda-list `(&environment ,env-sym)) env-sym))))
         `(cl:defmacro ,name ,lambda-list
            (let ((,expr (locally ,@body)))
              (optima:ematch (macroexpand-until (lambda (,form)
                                                  (and (listp ,form)
                                                       (member (car ,form) '(cl:let cl:let*))))
                                                ,expr)
                ((list* let-sym ,bindings ,let-body)
                 (list* let-sym ,bindings
                        `(declare ,@(type-decl-from-bindings
                                     ,bindings ,env-sym :parallel (string= "LET" let-sym)))
                        ,let-body))))))))))
                        
(define-modify-macro my-incf (&optional (num 1)) my-+)
(my-incf x (cl:the integer y))