;;; init-macros.el --- fns for creating commands, functions, and new syntax	-*- lexical-binding:t -*-

;; Author: Noah Friedman <friedman@splode.com>
;; Created: 2019-08-06
;; Public domain.

;; $Id: init-macros.el,v 1.13 2024/08/14 10:31:59 friedman Exp $

;;; Commentary:

;; These macros and functions are useful for customization files to handle
;; the differences between emacs versions, or to make preference settings
;; more compact.

;; Most of these macros have been lurking in my own customization files for years.

;;; Code:


(defun lisp-indent-like (function like)
  "Indent FUNCTION in the same mannner as LIKE, another function.
This copies LIKE's `lisp-indent-function' property to FUNCTION."
  (put function 'lisp-indent-function (get like 'lisp-indent-function)))


(defmacro defmacro-undefined (fn param &rest body)
  ;;(declare (indent 2) (debug t))
  `(if (fboundp ',fn) ',fn (defmacro ,fn ,param ,@body)))
(lisp-indent-like 'defmacro-undefined 'defmacro)


;; Emacs 21 and earlier don't grok (declare (indent ...))
(defmacro-undefined declare (&rest _ignore) nil)


(defmacro defun-undefined (fn param &rest body)
  (declare (indent 2) (debug t))
  `(if (fboundp ',fn) ',fn (defun ,fn ,param ,@body)))


(defun defalias-undefined (fn defn &rest rest)
  (if (fboundp fn) fn (apply 'defalias fn defn rest)))


;; For emacs 21 and earlier.  This is a byte compiler hint in later versions.
(defalias-undefined 'with-no-warnings 'progn)


;; defconst always sets the value of the SYMBOL.
;; This call does not rebind and does not eval initvalue unless
;; the symbol is currently unbound.
;; If the symbol is not already special, make it so.
(defmacro defconst-undefined (symbol initvalue &optional docstring)
  "Like `defconst', but do not alter any existing binding for SYMBOL.
The INITVALUE form will not be evaluated unless needed.

Regardless of any existing binding, the symbol will be made special if it
isn't already."
  (declare (indent 2) (debug t))
  `(cond ((not (boundp ',symbol))
          (defconst ,symbol ,initvalue ,@(if docstring (list docstring))))
         ((not (boundp 'lexical-binding)))
         ((special-variable-p ',symbol)
          ',symbol)
         ((defconst ,symbol ,symbol))))


;; Use with-no-warnings to suppress warnings about lacking a prefix
(defmacro defconst-setq (&rest pairs)
  (declare (debug t))
  (let ((forms nil))
    (while pairs
      (setq forms (cons `(defconst ,(car pairs) ,(car (cdr pairs)))
                         forms))
      (setq pairs (cdr (cdr pairs))))
    `(with-no-warnings
       ,@(nreverse forms))))


;; Added to Emacs in 24.3.
(defmacro-undefined defvar-local (var val &optional docstring)
  "Define VAR as a buffer-local variable with default value VAL.
Like ‘defvar’ but additionally marks the variable as being automatically
buffer-local wherever it is set."
  (declare (indent 2) (debug t))
  `(progn (defvar ,var ,val ,docstring)
          (make-variable-buffer-local ',var)))


;; Declare variables using defvar before setting default value.
;; This is for the benefit of emacsen which either complain that free
;; variables are being set, or which would otherwise be defined as lexical
;; variables in versions of emacs which support those.
(defmacro defvar-setq (&rest pairs)
  (declare (debug t))
  (let ((forms nil))
    (while pairs
      (setq forms (nconc `((setq ,(car pairs) ,(car (cdr pairs)))
                           (defvar ,(car pairs)))
                         forms))
      (setq pairs (cdr (cdr pairs))))
    `(progn ;; don't seem to need with-no-warnings here
       ,@(nreverse forms))))


;; There is a setq-local defined in v24.3 subr.el
;; but multiple pairs are not supported until v27.
(defmacro setq-locals (&rest pairs)
  "Make variables local to current buffer, and set them.

Make the variable VAR buffer-local if it isn't already, and set it to VALUE.
VAR, the variable name, is literal (not evaluated);
VALUE is an expression: it is evaluated and its value returned.

More generally, you can use multiple variables and values, as in
  (setq-locals VAR1 VALUE1 VAR2 VALUE2...)
This sets each VAR's buffer-local value to the corresponding VALUE.
The VALUE for the Nth VAR can refer to the new local values
of previous VARs.

\(fn [VAR VALUE]...)"
  (let ((forms nil))
    (while pairs
      (setq forms (cons `(set (make-local-variable ',(car pairs))
                              ,(car (cdr pairs)))
                        forms)
            pairs (cdr (cdr pairs))))
    (if (cdr forms)
        `(progn ,@(nreverse forms))
      (car forms))))
;;
(defalias-undefined 'setq-local 'setq-locals)

;; This is a macro so that we don't shadow variables in caller.
(defmacro init-map-plist (fn plist)
  (declare (debug t))
  (let ((plsym (make-symbol "plist")))
    `(let ((,plsym ,plist))
       (while ,plsym
         (funcall ,fn (car ,plsym) (cadr ,plsym))
         (setq ,plsym (cddr ,plsym))))))


(defmacro setq-default-values (&rest vlist)
  (let ((var (make-symbol "var"))
        (val (make-symbol "val"))
        (def (make-symbol "def")))
    `(init-map-plist (lambda (,var ,val)
                  (let ((,def (intern-soft (format "default-%s" ,var))))
                    (if (and ,def (boundp (symbol-value ,def)))
                        (set ,def (eval ,val))
                      (set-default ,var (eval ,val)))))
                ',vlist)))


(defmacro setq-unless-obsolete (&rest vlist)
  "Like setq, but do not assign variables if they are obsolete or unbound.

This should be used for variables which are obsolete in later versions of
Emacs and have no newer alternative in their place.

If the variable is unbound, it will not be set as this is an indication
that the variable is not only obsolete, but removed entirely."
  (let ((var (make-symbol "var"))
        (val (make-symbol "val")))
    `(init-map-plist (lambda (,var ,val)
                       (and (boundp ,var)
                            (not (get ,var 'byte-obsolete-variable))
                            (setq ,var ,val)))
                     ',vlist)))


(defmacro find-non-obsolete (&rest symbols)
  "Iterate through SYMBOLS, and return first non-obsolete and bound one.
If an obsolete symbol has a marked replacement, return that replacement."
  (let ((res (make-symbol "res"))
        (sym (make-symbol "sym"))
        (obs (make-symbol "obs"))
        (lst (make-symbol "symbols")))
    `(let ((,lst (quote ,symbols))
           (,res nil))
       (while (and (null ,res)
                   ,lst)
         (let ((,sym (car ,lst))
               (,obs nil))
           (setq ,lst (cdr ,lst))
        (cond ((setq ,obs (get ,sym 'byte-obsolete-variable))
               (setq ,lst (cons (car ,obs) ,lst)))
              ((setq ,obs (get ,sym 'byte-obsolete-info))
               (setq ,lst (cons (indirect-function ,sym) ,lst)))
              ((or (boundp ,sym)
                   (fboundp ,sym))
               (setq ,res ,sym)))))
       ,res)))


(defmacro icalled-interactively-p (kind)
  (cond ((not (fboundp 'called-interactively-p))
         (list 'interactive-p))
        ((string-lessp emacs-version "23.2") ;; 23.1 did not accept arg
         (list 'called-interactively-p))
        (t
         `(called-interactively-p ,kind))))


(defmacro command-funcall (fn &rest args)
  "If current function was called interactively, call FN interactively as well.
Otherwise, just make a normal lisp function call to FN.
Any additional ARGS are passed to FN."
  `(if (icalled-interactively-p 'interactive)
       (funcall-interactively ,fn ,@args)
     (funcall ,fn ,@args)))


(defmacro command-funcallrest (fn &rest args)
  "If current function was called interactively, call FN interactively as well.
Otherwise, just make a normal lisp function call to FN.

FN receives the same arguments as the callee function received
When actually called interactively.

When called from lisp, FN receives any remaining explicit args passed to
this function."
  `(if (icalled-interactively-p 'interactive)
       (call-interactively ,fn)
     (apply ,fn ,@args)))


(defmacro make-interactive (symbol &rest interactive-args)
  "Make the function definition of SYMBOL an interactive command.
Remaining arguments, if any, are passed to `interactive' in the function."
  (if (eq (car-safe symbol) 'quote)
      (setq symbol (car (cdr symbol))))
  `(defadvice ,symbol (before make-interactive activate)
     (interactive ,@interactive-args)))


(defmacro make-on-off-mode-commands (mode &optional on-value off-value)
  "Define new interactive commands which unconditionally turn MODE on or off.
The command names are `turn-on-MODE' and `turn-off-MODE'.

Optional args ON-VALUE and OFF-VALUE are the values for the commands to
 pass to the function MODE to enable or disable it.
 They default to 1 and -1, respectively.

Note: because this macro cannot distinguish between an explicit value of
 nil vs. an unspecified value, quote the symbol as \\='nil if you actually
 want to use that."
  (let* ((on-name  (intern (format "turn-on-%s"           mode)))
         (on-doc   (format "Unconditionally turn on %s."  mode))
         (off-name (intern (format "turn-off-%s"          mode)))
         (off-doc  (format "Unconditionally turn off %s." mode)))
    (if (null on-value)  (setq on-value   1))
    (if (null off-value) (setq off-value -1))
    `(progn
       (defun ,on-name  () ,on-doc  (interactive) (,mode ,on-value))
       (defun ,off-name () ,off-doc (interactive) (,mode ,off-value)))))


(defmacro init-eval-and-compile-when (pred &rest body)
  (declare (indent 1) (debug t))
  `(eval-and-compile (cond (cons ,pred ,body))))


(defmacro init-eval-and-compile-unless (pred &rest body)
  (declare (indent 1) (debug t))
  `(eval-and-compile (cond ((not ,pred) ,@body))))


(defmacro-undefined save-mark-and-excursion (&rest body)
  "Like `save-excursion', but also save and restore the mark state.
This macro does what `save-excursion' did before Emacs 25.1."
  (declare (indent 0) (debug t))
  (if (fboundp 'save-mark-and-excursion--save)
      (let ((saved-marker-sym (make-symbol "saved-marker")))
        `(let ((,saved-marker-sym (save-mark-and-excursion--save)))
           (unwind-protect
               (save-excursion ,@body)
             (save-mark-and-excursion--restore ,saved-marker-sym))))
    `(save-excursion ,@body)))

;; For emacs 23 and earlier reading later .autoloads.el
(defalias-undefined 'function-put 'put)



(defun-undefined keywordp (object)
  (and (symbolp object)
       (= (aref (symbol-name object) 0) ?:)))


;;; Control or iteration constructs

(defmacro nf:do (variable-init-step test-exprs &rest commands)
  "Usage: (do ((variable init step) ...) (test expressions ...) command ...)

`do' expressions are evaluated as follows: The `init' expressions are
evaluated \(in order from left to right as specified\), the `variables' are
bound to fresh locations, the results of the `init' expressions are
stored in the bindings of the `variables', and then the iteration phase
beings.

Each iteration begins by evaluating `test'; if the result is false, then
the `command' expressions are evaluated in order, then the `step'
expressions are evaluated in the order, the associated `variables' are
bound to their results, and the next iteration begins.

If `test' evaluates to a true value, then the `expressions' are
evaluated from left to right and the value of the last expression is
returned as the value of the do expression.  If no expressions are present,
then the value of `test' is returned.

If both a step and init are omitted, then the result is the same as if
\(variable nil nil\) had been written instead of \(variable\)."
  (declare (indent 2) (debug t))
  `(let ,(mapcar (lambda (arg)
                   (list (car arg) (car (cdr arg))))
                 variable-init-step)
     (while (not ,(car test-exprs))
       ,@commands
       ,@(mapcar (lambda (arg)
                   (let ((step (nthcdr 2 arg)))
                     (and step
                          (list 'setq (car arg) (car step)))))
                 variable-init-step))
     ,@(cdr test-exprs)))


(provide 'init-macros)

;;; init-macros.el ends here.