Download
(eval-when-compile (require 'cl))
(unless (and (intern-soft "*IS-MON-OBARRAY*")
(bound-and-true-p *IS-MON-OBARRAY*))
(setq *IS-MON-OBARRAY* (make-vector 17 nil)))
(require 'edebug)
(declare-function mon-g2be "mon-buffer-utils" (&optional min/max-go no-go))
(declare-function mon-list-proper-p "mon-seq-utils" (putatively-proper))
(declare-function mon-mapcar "mon-seq-utils" (mapcar-fun mapcar-lst &rest more-lsts))
(declare-function mon-gensym-counter-randomizer "mon-randomize-utils" (randomize-sym/str))
(defgroup mon-macs nil
"Customization group for variables and functions of :FILE mon-macs.el\n
:SEE-ALSO .\n►►►"
:link '(url-link
:tag ":EMACSWIKI-FILE (URL `http://www.emacswiki.org/emacs/mon-macs.el')")
:link '(emacs-library-link
:tag ":FILE mon-macs.el"
"mon-macs.el")
:group 'mon-base)
(defcustom *mon-macs-xrefs*
'(mon-error-protect %mon-format-chk-keys handler-case mon-copy-list-mac
mon-mapcar-mac mon-nshuffle-vector mon-list-sift mon-foreach mon-for mon-loop
mon-equality-for-type mon-gensym mon-with-gensyms mon-with-print-gensyms
defconstant defparameter mon-set-text-properies-region mon-get-face-at-posn
mon-with-file-buffer mon-buffer-exists-p mon-with-buffer-undo-disabled
mon-print-in-buffer-if-p mon-with-inhibit-buffer-read-only
mon-toggle-restore-llm mon-naf-mode-toggle-restore-llm mon-line-dolines
mon-cat *mon-macs-xrefs*)
"Xrefing list of `mon-*' macros.\n
The symbols contained of this list are defined in :FILE mon-macs.el\n
:SEE-ALSO `*mon-default-loads-xrefs*', `*mon-default-start-loads-xrefs*',
`*mon-dir-locals-alist-xrefs*', `*mon-keybindings-xrefs*',
`*mon-testme-utils-xrefs*', `*mon-button-utils-xrefs*',
`*mon-buffer-utils-xrefs*', `*mon-error-utils-xrefs*', `*mon-line-utils-xrefs*',
`*mon-macs-xrefs*', `*mon-plist-utils-xrefs*', `*mon-post-load-hooks-xrefs*',
`*mon-seq-utils-xrefs*', `*mon-string-utils-xrefs*', `*mon-type-utils-xrefs*',
`*mon-window-utils-xrefs*', `*naf-mode-xref-of-xrefs*', `*mon-slime-xrefs*',
`*naf-mode-faces-xrefs*', `*naf-mode-date-xrefs*', `*mon-ulan-utils-xrefs*',
`*mon-xrefs-xrefs'.\n►►►"
:type '(repeat symbol)
:group 'mon-macs
:group 'mon-xrefs)
(defmacro mon-error-protect (err-arg &rest body)
"Signal an error inside a `condition-case' form but ignore it momentarily.\n
The \"protected\" condidtion-case BODYFORM is evaluated with `ignore-errors'
non-nil for the duration of BODY.\n
When body returns normally (i.e. no errors were signaled during body) protect when
`error` is the default handler.\n
ERR-ARG is the form returned from the error condition handler.\n
:EXAMPLE\n\n\(let \(pre-error\) ;; Value we want to ensure executes inside BODY
;; If an error is signaled in body let us know, but delay
\(prog1 \(when \(eq \(mon-error-protect
'error-but-body-executed
\(progn
\(setq pre-error \"pre-error got set\"\)
\(error \"\"\)\)\) 'error-but-body-executed\)
'error-but-body-executed\)
;; First show what happened inside body:
\(minibuffer-message pre-error\)\)\)\n
\(mon-error-protect-PP-EXPAND-TEST
'\(mon-error-protect 'never-see-me\)\)\n
\(mon-error-protect-PP-EXPAND-TEST
'\(mon-error-protect 'will-see-me '\(/ 0 0\)\)\)\n
\(mon-error-protect-PP-EXPAND-TEST
'\(let \(pre-error\) ;; Value we want to ensure executes inside body
;; If an error is signaled in body let us know, but delay
\(prog1 \(when \(eq \(mon-error-protect
'error-but-body-executed
'\(progn
\(setq pre-error \"pre-error got set\"\)
\(error \"\"\)\)\) 'error-but-body-executed\)
'error-but-body-executed\)
;; First show what happened inside body:
\(minibuffer-message pre-error\)\)\)\)\n
:SEE-ALSO `stack-trace-on-error', `report-errors', `mon-error',
`mon-error-toplevel',`mon-error-gather', `mon-error-gather-peek',
`mon-error-string-err-format', `mon-message', `redirect-debugging-output',
`external-debugging-output', `debug-on-signal', `debug-on-error',
`debug-ignored-errors', `signal-hook-function', `*mon-emacs-help-errors*',
`mon-help-errors', `Info-no-error', `mon-help-CL-error-condition-restart'.\n►►►"
(let ((bdy-wrap (make-symbol "bdy-wrap")))
`(let ((,bdy-wrap (or ,@body t)))
(condition-case nil
(unless (ignore-errors (or (null (eval ,bdy-wrap)) t))
(error ""))
(error ,err-arg)))))
(defmacro %mon-format-chk-keys (w-keys-lst)
"Helper macro `mon-format' map and verify keyword arguments.\n
Return a 4 elt list of values extracted from W-KEYS.\n
Arg W-KEYS is a list of are keywords/value pair arguments to `mon-format'.
Valid keywords are:\n
:w-fun :w-spec :w-args :w-delim\n
:EXAMPLE\n
\(pp-macroexpand-expression
'\(%mon-format-chk-keys '\(:w-fun
:w-spec \":bubba bobby %d\\n\"
:w-args 8
:w-delim t\)\)\)\n
\(pp-macroexpand-expression
'\(%mon-format-chk-keys '\(:w-spec \":bubba bobby %d\\n\"
:w-args 8
:w-delim t
:w-fun 'format\)\)\n
\(pp-macroexpand-expression
'\(%mon-format-chk-keys '\(:w-spec :w-args :w-delim :w-fun #'format\)\)\)\n
;; Following is with :w-delim without an value it is correctly ignored.
\(pp-macroexpand-expression
'\(%mon-format-chk-keys
'\(:w-delim
:w-spec '\(\":FUNCTION `mon-format' \"
\"-- example message with arg `%S' and arg `%d'\"\)
:w-fun #'\(lambda \(&rest x\)
\(setq x \(concat \(apply #'format x\) \"\\n\" \)\)
\(princ x \(get-buffer-create \"*MON-FORMAT*\"\)\)
\(display-buffer \"*MON-FORMAT*\"\)\)
:w-args '\(bubba 666\)\)\)\)\n
;; Following is with missing :w-fun key/value pair:
\(pp-macroexpand-expression
'\(%mon-format-chk-keys '\(:w-spec '\(\":bubba\" \"bobby\"\)
:w-args 8
:w-delim t\)\)\)\n
;; Following is without key/value pairs:
\(pp-macroexpand-expression '\(%mon-format-chk-keys nil\)\)\n
:SEE-ALSO `destructuring-bind', `edebug-match-&key', `lambda-list-keywords'.\n►►►"
(declare (indent 0) (debug t))
(let ((mf-keys (make-symbol "--mf-keys--"))
(mf-chk-keys '(:w-fun :w-spec :w-args :w-delim)))
`(let ((,mf-keys
(mapcar #'(lambda (mf-L-0a)
(and (setq mf-L-0a (memq mf-L-0a ,w-keys-lst))
(not (memq (cadr mf-L-0a) (quote ,mf-chk-keys)))
(cadr mf-L-0a)))
(quote ,mf-chk-keys))))
,mf-keys)))
(defmacro handler-case (expression &rest clauses)
"Attempt to be like Common Lisp's `handler-case'.\n
The clause variable symbols are substituted by one single `condition-case'
variable symbol.
:NOTE This may cause problems if the same symbol is used as data or if it's a dynamic
variable.
EXPRESSION a form.
CLAUSES ::= <ERROR-CLAUSE> | <NO-ERROR-CLAUSE>
ERROR-CLAUSE ::= (typespec ([var]) {declaration}* {form}*)
NO-ERROR-CLAUSE ::= (:no-error LAMBDA-LIST {declaration}* {form}*)
:EXAMPLE\n\n
:SEE-ALSO `mon-error-protect', `stack-trace-on-error'.\n►►►"
(let* ((var (edebug-gensym "--mon-"))
(neclause (assoc-string :no-error clauses t))
(nell (cadr neclause))
(nebody (cddr neclause))
(handlers (mapcar #'(lambda (clause)
(let ((typespec (car clause))
(clausvar (cadr clause))
(body (cddr clause))
(cds-L-1 #'(lambda (cds-L-1-new cds-L-1-old cds-L-1-tree)
(cond ((eq cds-L-1-tree cds-L-1-old) cds-L-1-new)
((consp cds-L-1-tree)
(with-no-warnings
(let ((cds-L-1-a
(apply cds-L-1 (list cds-L-1-new cds-L-1-old (car cds-L-1-tree))))
(cds-L-1-d
(apply cds-L-1 (list cds-L-1-new cds-L-1-old (cdr cds-L-1-tree)))))
(if (and (eq cds-L-1-a (car cds-L-1-tree)) (eq cds-L-1-d (cdr cds-L-1-tree)))
cds-L-1-tree (cons cds-L-1-a cds-L-1-d)))))
(t cds-L-1-tree))))
)
(cons (if (and (consp typespec)
(eq 'or (car typespec)))
(cdr typespec)
typespec)
(if (null clausvar)
body
(apply cds-L-1 (list var (car clausvar) body)) ))))
(remove neclause clauses))))
(if neclause
`(condition-case ,var
(multiple-value-bind ,nell ,expression ,@nebody)
,@handlers)
`(condition-case ,var
,expression
,@handlers))))
(defmacro mon-copy-list-mac (cpy-lst)
"Macrofied version of `copy-list'/`copy-tree'.\n
Return a copy of list, which may be a dotted list.\n
Elements of list are not copied, just the list structure itself.\n
:EXAMPLE\n\n\(mon-copy-list-mac '\(a nil . \(c . d\)\)\)\n
\(mon-copy-list-mac '\(a b \(nil . \(c . d\)\)\)\)\n
\(mon-copy-list-mac '\(a b \(c . d\)\)\)\n
\(mon-copy-list-mac [nil 3]\)\n
\(mon-copy-list-mac '\(a b . \(c . d\)\)\)\n
\(pp-macroexpand-expression '\(mon-copy-list-mac '\(a b \(c . d\)\)\)\)\n
\(pp-macroexpand-expression '\(mon-copy-list-mac '\(a b . \(c d\)\)\)\)\n
\(pp-macroexpand-expression '\(mon-copy-list-mac '\(a b . \(c . d\)\)\)\)\n
:NOTE `copy-sequence' signals an error when we try to copy the dotted list.\n
CL `copy-list' returns a copy of CPY-LST even when a dotted list as does
`copy-tree', but the latter copies recursively along cdrs with additional checks
for vectors which we don't need/want.\n So, to avoid byte compiler warnings for
the `mon-map1' fncns we will use this litle fella instead.\n
Following checks help verify that list copies returned from `mon-copy-list-mac' and
`copy-tree' are functionaly equivalent:\n
\(let \(\(cp '\(a b . \(nil . \(c . d\)\)\)\) ;≣ \(a b nil c . d\)
cp-mac cp-tree cp-lst-CL\)
\(setq cp-mac \(mon-copy-list-mac cp\)\)
\(setq cp-tree \(copy-tree cp\)\)
\(setq cp-lst-CL \(copy-list cp\)\)
`\(:macro-vrsn ,\(progn \(setcdr \(cdddr cp-mac\) \"bubba mac\"\) cp-mac\)
:tree-vrsn ,\(progn \(setcdr \(cdddr cp-tree\) \"bubba tree\"\) cp-tree\)
:CL-vrsn ,\(progn \(setcdr \(cdddr cp-lst-CL\) \"bubba CL\"\) cp-lst-CL\)
:orig-dttd-l ,cp \)\)\n
\(let \(chk-equal\)
\(setq chk-equal
`\(,\(let \(\(mac-cmplx-strct '\([a nil] . \(nil . [c \(d . [q z]\)]\)\)\)
mac-aset-cmplx\)
\(setq mac-aset-cmplx \(mon-copy-list-mac mac-cmplx-strct\)\)
\(aset \(cdr \(aref \(cddr mac-aset-cmplx\) 1\)\) 1 'bubba-aset\)
`\(:asetd-mac ,mac-aset-cmplx :orig ,mac-cmplx-strct\)\)
,\(let \(\(tree-cmplx-strct '\([a nil] . \(nil . [c \(d . [q z]\)]\)\)\)
tree-aset-cmplx\)
\(setq tree-aset-cmplx \(mon-copy-list-mac tree-cmplx-strct\)\)
\(aset \(cdr \(aref \(cddr tree-aset-cmplx\) 1\)\) 1 'bubba-aset\)
`\(:asetd-tre ,tree-aset-cmplx :orig ,tree-cmplx-strct\)\)
,\(let \(\(mac-setf-cmplx '\([a nil] . \(nil . [c \(d . [q z]\)]\)\)\)
mac-setfd\)
\(setq mac-setfd \(mon-copy-list-mac mac-setf-cmplx\)\)
\(setf \(aref \(cdr \(aref \(cddr mac-setfd\) 1\)\) 1\) 'bubba-setfd\)
`\(:setfd-mac ,mac-setfd :orig ,mac-setf-cmplx\)\)
,\(let \(\(tre-setf-cmplx '\([a nil] . \(nil . [c \(d . [q z]\)]\)\)\)
tree-setfd\)
\(setq tree-setfd \(mon-copy-list-mac tre-setf-cmplx\)\)
\(setf \(aref \(cdr \(aref \(cddr tree-setfd\) 1\)\) 1\) 'bubba-setfd\)
`\(:setfd-tre ,tree-setfd :orig ,tre-setf-cmplx\)\)\)\)
\(setq chk-equal `\(:equal-tre-aset-orig
,\(equal \(cadr \(assq :asetd-tre chk-equal\)\)
\(cadddr \(assq :asetd-tre chk-equal\)\)\)
:equal-mac-aset-orig
,\(equal \(cadr \(assq :asetd-mac chk-equal\)\)
\(cadddr \(assq :asetd-mac chk-equal\)\)\)
:equal-asetd-mac-orig-tre-orig
,\(equal \(cadddr \(assq :asetd-tre chk-equal\)\)
\(cadddr \(assq :asetd-mac chk-equal\)\)\)
:equal-tre-setfd-orig
,\(equal \(cadr \(assq :setfd-tre chk-equal\)\)
\(cadddr \(assq :setfd-tre chk-equal\)\)\)
:equal-mac-setfd-orig
,\(equal \(cadr \(assq :setfd-mac chk-equal\)\)
\(cadddr \(assq :setfd-mac chk-equal\)\)\)
:equal-mac-setfd-orig-tre-setfd-orig
,\(equal \(cadddr \(assq :setfd-tre chk-equal\)\)
\(cadddr \(assq :setfd-mac chk-equal\)\)\)
,@chk-equal\)\)\)\n
:SEE-ALSO `mon-mapl', `mon-maplist', `mon-mapcar', `mon-mapcan', `mon-mapcon',
`mon-map'.\n►►►"
(let ((mclm-res (make-symbol "mclm-res"))
(mclm-cpy (make-symbol "mclm-cpy")))
`(let ((,mclm-cpy ,cpy-lst)
(,mclm-res nil))
(if (consp ,mclm-cpy)
(if (mon-list-proper-p ,mclm-cpy)
(copy-sequence ,mclm-cpy)
(progn
(while (consp ,mclm-cpy) (push (pop ,mclm-cpy) ,mclm-res))
(prog1 (nreverse ,mclm-res) (setcdr ,mclm-res ,mclm-cpy))))
(car ,mclm-cpy)))))
(defmacro mon-mapcar-mac (mapmac-fun seq1 &rest seqs2_n)
"Apply MAPMAC-FUN to each element of SEQ1 and make a list of the results.\n
If there are several &rest sequences, MAPMAC-FUN is called with that many arguments.
Mapping terminates with the shortest sequence.\n
With just one sequence, this is like `mapcar'.\n
With several, it is like the Common Lisp `mapcar' function extended to arbitrary
sequence types.\n
:EXAMPLE\n\n\(mon-mapcar-mac 'list '\(a b c\) '\(1 2 3\) '\(d e f\) '\(4 5 6\)\)\n
\(mon-mapcar-mac 'cons '\(a b c\) '\(1 2 3\)\)\n
\(pp-macroexpand-expression '\(mon-mapcar-mac 'cons '\(a b c\) '\(1 2 3\)\)\)\n
\(let* \(\(tmp-alst '\(\(KEY-D D0 D1 D2\)\)\)
\(tmp-keys '\(KEY-A KEY-B KEY-C\)\)
\(tmp-vals '\(\(A0 A1 A2\) \(B0 B1 B2\) \(C0 C1 C2\)\)\)
\(rtn-mon-mapcar tmp-alst\)
rtn-pairlis\)
\(setq rtn-mon-mapcar \(nconc \(mon-mapcar #'cons tmp-keys tmp-vals\) tmp-alst\)\)
\(setq rtn-pairlis \(pairlis tmp-keys tmp-vals tmp-alst\)\)
`\(:TREE-EQUAL-MMC-PAIRL ,\(tree-equal rtn-mon-mapcar rtn-pairlis\)
:MON-MAPCAR/PAIRLIS ,rtn-mon-mapcar :CL-PKG/PAIRLIS ,rtn-pairlis\)\)\n
:NOTE Last example is basically Emacs lisp's version of Common Lisp's `parilis'.\n
:SEE-ALSO `mon-mapcar', `mon-map1', `mon-mapcan', `mon-mapcon', `mon-mapl',
`mon-maplist', `mon-maptree', `mon-map-combine', `mon-map-append', `mon-map'.\n►►►"
(if (not seqs2_n)
`(mapcar ,mapmac-fun ,seq1)
(let* ((mmc-seqs (cons seq1 seqs2_n))
(mmc-cnt 0)
(mmc-heads (mapcar
#'(lambda (mmc-L-1)
(make-symbol (concat "--mmc-L-1_"
(number-to-string (setq mmc-cnt (1+ mmc-cnt))))))
mmc-seqs))
(mmc-rslt (make-symbol "mmc-rslt"))
(mmc-rslt-tl (make-symbol "mmc-rslt-tl")))
`(let* ,(let* ((mmc-bind (cons nil nil))
(mmc-heads mmc-heads))
(nconc mmc-bind (list (list mmc-rslt '(cons nil nil))))
(nconc mmc-bind (list (list mmc-rslt-tl mmc-rslt)))
(while mmc-heads
(nconc mmc-bind (list (list (pop mmc-heads) (pop mmc-seqs)))))
(cdr mmc-bind))
(while (and ,@mmc-heads)
(setcdr ,mmc-rslt-tl
(cons (funcall ,mapmac-fun ,@(mapcar #'(lambda (mmc-L-2)
(list 'car mmc-L-2))
mmc-heads))
nil))
(setq ,mmc-rslt-tl (cdr ,mmc-rslt-tl)
,@(apply #'nconc
(mapcar #'(lambda (mmc-L-3)
(list mmc-L-3 (list 'cdr mmc-L-3)))
mmc-heads))))
(cdr ,mmc-rslt)))))
(defmacro mon-nshuffle-vector (mixup-vector)
"Destructive random permutation of MIXUP-VECTOR elts, return MIXUP-VECTOR.\n
All permutations are equally likely.\n
:EXAMPLE\n\n\\(pp-macroexpand-expression
'\(mon-nshuffle-vector [37 41 43 47 53 59]\)\)\n
:ALIASED-BY `nshuffle-vector'\n
:SEE-ALSO `mon-list-nshuffle', `mon-list-shuffle-safe',`shuffle-vector',
`slime-shuffle-list'.\n►►►"
(declare (indent 0) (debug t))
(let ((mnsv-vec (make-symbol "mnsv-vec"))
(mnsv-incr (make-symbol "mnsv-incr"))
(mnsv-rndmz (make-symbol "mnsv-rndr"))
(mnsv-temp (make-symbol "mnsv-temp"))
(mnsv-len (make-symbol "mnsv-len")))
`(let ((,mnsv-vec ,mixup-vector)
(,mnsv-incr 0)
(,mnsv-len (length ,mixup-vector))
,mnsv-rndmz
,mnsv-temp)
(while (< ,mnsv-incr ,mnsv-len)
(setq ,mnsv-rndmz (+ ,mnsv-incr (random (- ,mnsv-len ,mnsv-incr))))
(setq ,mnsv-temp (aref ,mnsv-vec ,mnsv-incr))
(aset ,mnsv-vec ,mnsv-incr (aref ,mnsv-vec ,mnsv-rndmz))
(aset ,mnsv-vec ,mnsv-rndmz ,mnsv-temp)
(setq ,mnsv-incr (1+ ,mnsv-incr)))
,mnsv-vec)))
(defmacro mon-list-sift (sift-list &rest sift-tests)
"SIFT-LIST with SIFT-TESTS.\n
On a Common Lisp return is as if by values.\n
:EXAMPLE\n
\(mon-list-sift '\( 1 2 3 4 5 6 7 8 9 10\) #'\(lambda \(x\) \(> x 4\)\)\)
;=> \(10 9 8 7 6 5\) \(4 3 2 1\)\n
\(mon-list-sift '\(1 2 3 -1 -2 -3\) #'oddp #'plusp\)
;=> \(-3 -1 3 1\) \(2\) \(-2\)\n
\(mon-list-sift '\(1 2 3 -1 -2 -3\) #'plusp #'oddp\)
;=> \(3 2 1\) \(-3 -1\) \(-2\)\n
:SEE-ALSO `mon-list-filter', `mon-list-last', `mon-delete-first',
`mon-equality-for-type', `mon-equality-or-predicate', `car-less-than-car'.\n►►►"
(let ((mls-gthr-sftd (mon-mapcar #'(lambda (mls-L-1)
(edebug-gensym "--mon-sift-cllct--"))
sift-tests))
(mls-sft-last (edebug-gensym "--mon-sift-last--")))
`(let (,@mls-gthr-sftd ,mls-sft-last)
(dolist (mls-sft-itm ,sift-list)
(cond ,@(mon-mapcar #'(lambda (mls-L-2 mls-l-3)
`((funcall ,mls-L-2 mls-sft-itm)
(push mls-sft-itm ,mls-l-3)))
sift-tests mls-gthr-sftd)
(t (push mls-sft-itm ,mls-sft-last))))
(list ,@mls-gthr-sftd ,mls-sft-last))))
(defmacro mon-foreach (w-var on-list &rest body)
"A foreach style macro idiom for looping W-VARS ON-LIST with BODY.\n
:EXAMPLE\n\n\(mon-foreach for-var ; <- w-var
'\(1 2 3 4) ; <- on-list
\(+ for-var for-var\)\) ; <- body\n
\(pp-macroexpand-expression
'\(mon-foreach for-var '\(1 2 3 4\) \(+ for-var for-var\)\)\)\n
:SEE-ALSO `mon-for', `mon-loop', `mon-mapcar'.\n►►►"
`(mapcar #'(lambda (,w-var) ,@body) ,on-list))
(defmacro mon-for (var init final &rest body)
"Execute a simple for loop .\n
:EXAMPLE\n\n\(mon-for i 1 10 \(print i\)\)\n
\(pp-macroexpand-expression '\(mon-for i 1 10 \(print i\)\)\)\n
:SEE-ALSO `mon-foreach', `mon-loop', `mon-mapcar'.\n►►►"
(let ((mf-tempvar (make-symbol "mf-tempvar")))
`(let ((,var ,init)
(,mf-tempvar ,final))
(if (< ,var ,mf-tempvar)
(while (<= ,var ,mf-tempvar)
,@body
(setq ,var (+ ,var 1)))
(while (>= ,var ,mf-tempvar)
,@body
(setq ,var (- ,var 1)))))))
(defmacro mon-loop (clauses &rest body)
"Macro to execute a loop over clauses.\n
:SEE-ALSO `mon-foreach', `mon-for', `mon-mapcar'.\n►►►"
(if (null clauses)
`(progn ,@body)
`(loop ,@(car clauses) do (mon-loop ,(cdr clauses) ,@body))))
(defmacro mon-equality-for-type (thing)
"Return preferred equality predicate for thing.\n
:EXAMPLE\n\n\(mon-equality-for-type 3.3\)
\(pp-macroexpand-expression '\(mon-equality-for-type \"string\"\)\)
:SEE-ALSO `mon-equality-or-predicate',
`*mon-equality-or-predicate-function-types*'
`mon-get-text-properties-parse-prop-val-type-chk', `deftype', `type-of',
`typep', `coerce'.\n►►►"
(declare (indent 0) (debug t))
(let ((meft-thing (make-symbol "meft-thing")))
`(let ((,meft-thing (type-of ,thing)))
(or
(and (memq ,meft-thing '(integer symbol buffer
frame window marker char-table
hash-table subr ))
'eq)
(and (memq ,meft-thing '(cons string vector bool-vector char-table)) 'equal))
(and (eq ,meft-thing 'float) 'eql))
))
(defmacro mon-gensym (&optional prefix counter)
"Generate a new uninterned symbol.\n
When optional arg PREFIX (a string) return a symbol-name by appending the value
of `*gensym-counter*' to PREFIX. The default prefix is \"M\".\n
When optional arg COUNTER satisfies the predicate `integerp' and PREFIX
satisfies the predicate `stringp' it is appended to PREFIX instead of
`*gensym-counter*'s value.\n
Like the `gensym' function in CL package but defined as a macro instead.\n
:EXAMPLE\n\n\(pp-macroexpand-expression '\(mon-gensym\)\)\n
\(pp-macroexpand-expression '\(mon-gensym \"EG\" 666\)\)\n
:NOTE `edebug-gensym' is identical to the `gensym' but doesn't sigal a
byte-compiler warning.\n
:SEE-ALSO `mon-gensym-counter-randomizer', `mon-with-gensyms',
`mon-gensym-counter-randomizer-TEST', `edebug-gensym'
`easy-menu-make-symbol', `easy-menu-item-count'.\n►►►"
(declare (indent 0) (debug t))
(let ((mgs-pfix (make-symbol "mgs-pfix"))
(mgs-num (make-symbol "mgs-num")))
`(let ((,mgs-pfix (cond ((and ,prefix (stringp ,prefix)) ,prefix)
((and ,prefix (not (stringp ,prefix)))
(symbol-name ,prefix))
(t "M")))
(,mgs-num (if (and ,prefix ,counter (integerp ,counter))
,counter
(prog1
edebug-gensym-index
(incf edebug-gensym-index)))))
(make-symbol (format "%s%d" ,mgs-pfix ,mgs-num)))))
(defmacro mon-with-gensyms (w-syms &rest body)
"Execute BODY in a context where the variables in W-SYMS are bound to
freshly allocated uninterned symbol as returned by `mon-gensym'.\n
:EXAMPLE\n\n\(unwind-protect
\(progn
\(defmacro tt--mgs \(arg1 arg2 arg3\)
\(mon-with-gensyms
\(somea someb somec get-some\)
`\(let \(\(,somea ,arg1\)
\(,someb ,arg2\)
\(,somec ,arg3\)
\(,get-some \(\)\)\)
\(dolist \(q \(list ,somea ,someb ,somec\)
\(setq ,get-some
\(mapconcat 'identity \(nreverse ,get-some\) \"\\n\"\)\)\)
\(push \(concat \"a name: \" q \) ,get-some\)\)
\(and \(null \(fboundp 'tt--mgs\)\)
\(equal ,get-some \"a name: bubba\\na name: sally\\na name: suzy\"\)\)\)\)\)
\(pp-macroexpand-expression '\(tt--mgs \"bubba\" \"sally\" \"suzy\"\)\)\)
\(progn \(fmakunbound 'tt--mgs\) \(unintern 'tt--mgs\)\)\)\n
:NOTE `edebug-gensym' is identical to the `gensym' but doesn't sigal a CL
byte-compiler warning.\n
:ALIASED-BY `with-gensyms'\n
:SEE-ALSO `mon-gensym-counter-randomizer', `mon-gensym', `mon-with-print-gensyms'.\n"
(declare (indent 0) (debug t))
`(let ,(mapcar #'(lambda (mwg-mks)
`(,mwg-mks (mon-gensym
,(symbol-name mwg-mks)
,(mon-gensym-counter-randomizer mwg-mks)))) w-syms)
,@body))
(defmacro mon-with-print-gensyms (&rest body)
"Evaluate body with `print-gensym' bound `non-nil'.\n
:EXAMPLE\n
\(save-excursion
\(mon-with-inhibit-buffer-read-only
\(newline\) \(newline\)
\(mon-with-print-gensyms
\(princ
\(pp-to-string
`\(let \(was-sym\)
\(prog2
\(setq was-sym
\(symbol-name
\(car '\(,\(make-symbol
\(format \"not-a-sym-%d\" \(random\)\)\)\)\)\)\)
\(and \(not \(intern-soft was-sym obarray\)\)
\(not \(unintern was-sym obarray\)\)\)\)\)\)
\(current-buffer\)\)\)\)\)\n
\(pp-macroexpand-expression
'\(mon-with-print-gensyms
\(let \(hld-buba\)
\(setq hld-buba `\(,\(make-symbol \(format \"not-a-sym-%d\" \(random\)\)\)\)\)
\(prin1 hld-buba \(current-buffer\)\)\)\)\)\n
:ALIASED-BY `with-print-gensyms'\n
:SEE-ALSO `mon-gensym', `print-circle', `read-circle', `mon-help-print-functions'.\n►►►"
(declare (indent 0) (debug t))
`(let ((print-gensym t))
,@body))
(defmacro defconstant (symbol initvalue &optional docstring)
`(defconst ,symbol ,initvalue ,docstring))
(eval-when (compile)
(let ((defcon-d (replace-regexp-in-string "^(fn.*)$" "" (documentation 'defconst))))
(setq defcon-d
(concat defcon-d
(mapconcat
#'identity
'(":NOTE This is a CL compatibility feature, it macro-expands to elisp's `defconst'.\n"
":EXAMPLE\n\n(pp-macroexpand-expression '(defconstant bubba-consistently \"doin' the bubba\" \"undocd\"\)\)\n"
":SEE info node `(CL)Porting Common Lisp'.\n"
":SEE-ALSO `defparameter', `defvar', `defcustom', `set-variable',"
"`make-local-variable', `make-variable-buffer-local', `make-symbol', `intern',"
"`intern-soft', `obarray', `boundp', `bound-and-true-p', `makunbound', `unintern'."
"►►►") "\n")))
(put 'defconstant 'function-documentation defcon-d)))
(defmacro defparameter (param-name &optional initial-value docstring)
"Unconditionally assign the INITIAL-VALUE to the dynamic variable named NAME.\n
In contrast to `defvar' the defparameter macro assigns INITIAL-VALUE (if
supplied) to the dynamic variable named NAME only if NAME is not already bound.\n
If no INITIAL-VALUE is supplied, `defvar' leaves the value cell of the dynamic
variable named NAME undisturbed; if NAME was previously bound, its old value
persists, and if it was previously unbound, it remains unbound.\n
If DOCSTRING is supplied, it is attached to NAME as a documentation
string of kind variable.\n
:EXAMPLE\n\n\(pp-macroexpand-expression '\(defparameter \"tt-\"\)\)
:NOTE This is a CL compatibility feature and expands to elisp's defvar.\n
:SEE info node `(elisp)Defining Variables'\n
:SEE-ALSO `defconstant', `defconst', `defcustom', `set-variable',
`make-local-variable', `make-variable-buffer-local', `user-variable-p',
`make-symbol', `intern', `intern-soft', `obarray', `boundp', `bound-and-true-p',
`makunbound', `unintern'.\n►►►"
`(progn
(defvar ,param-name nil ,docstring)
(setq ,param-name ,initial-value)))
(defmacro mon-set-text-properies-region (props &rest body)
"Execute BODY and add PROPS to all the text it inserts.\n
More precisely, PROPS are added to the region between the point's positions
before and after executing BODY.\n
:SEE-ALSO `mon-insert-w-text-properties'.\n►►►"
(let ((start (edebug-gensym)))
`(let ((,start (point)))
(prog1 (progn ,@body)
(add-text-properties ,start (point) ,props)))))
(put 'mon-set-text-properies-region 'lisp-indent-function 1)
(defmacro mon-get-face-at-posn (position)
"Return a list of faces at POSITION.\n
:SEE-ALSO `mon-get-face-at-point', `mon-help-faces',
`mon-help-faces-basic', `mon-help-faces-themes'.\n►►►"
(let ((mgfap-pos (make-symbol "mgfap-pos")))
`(let ((,mgfap-pos ,position))
(delq nil (cons (get-text-property ,mgfap-pos 'face)
(mapcar #'(lambda (overlay)
(overlay-get overlay 'face))
(overlays-at ,mgfap-pos)))))))
(defmacro mon-with-file-buffer (w-buffer-var w-file &rest body)
"Evaluate BODY with W-BUFFER-VAR bound to buffer visiting W-FILE.\n
:EXAMPLE\n
\(let \(read-some\)
\(with-file-buffer some-buffer some-file
\(save-excursion
\(set-buffer some-buffer\)
\(mon-g2be -1\)
\(setq read-some \(read some-buffer\)\)\)\)\)\n
:SEE-ALSO `mon-with-buffer-undo-disabled', `mon-buffer-exists-p',
`mon-buffer-written-p', `mon-buffer-exists-so-kill', `mon-print-in-buffer-if-p',
`mon-get-buffer-w-mode', `mon-get-buffer-parent-dir',
`mon-get-proc-buffers-directories', `mon-get-buffers-directories',
`mon-string-split-buffer-name', `mon-string-split-buffer-parent-dir',
`with-current-buffer', `with-temp-file', `with-temp-buffer',
`get-file-buffer', `find-buffer-visiting', `buffer-file-truename',
`mon-help-buffer-functions'.\n►►►"
(let ((mwfb-fl-var (make-symbol "mwfb-fl-var"))
(mwfb-bfr-p (make-symbol "mwfb-bfr-p")))
`(let* ((,mwfb-fl-var ,w-file)
(,w-buffer-var (get-file-buffer ,mwfb-fl-var))
(,mwfb-bfr-p ,w-buffer-var))
(unless ,mwfb-bfr-p
(setq ,w-buffer-var (find-file-noselect ,mwfb-fl-var)))
(unwind-protect
(progn ,@body)
(unless ,mwfb-bfr-p
(kill-buffer ,w-buffer-var))))))
(defmacro mon-buffer-exists-p (buffer-to-check &optional no-invert)
"Return buffer-name of BUFFER-TO-CHECK if it exists.\n
When BUFFER-TO-CHECK is a buffer object return a string.\n
When BUFFER-TO-CHECK is a string return a buffer object.\n
When optional arg NO-INVERT is non-nil the `type-of' BUFFER-TO-CHECK is returned
without inversion.\n
:EXAMPLE\n\n\(mon-buffer-exists-p \(current-buffer\)\)\n
\(mon-buffer-exists-p \(buffer-name \(current-buffer\)\)\)\n
\(mon-buffer-exists-p \(current-buffer\) 'no-invert\)\n
\(mon-buffer-exists-p \(buffer-name \(current-buffer\)\) 'no-invert\)\n
\(with-temp-buffer \(mon-buffer-exists-p \(current-buffer\)\)\)\n
\(with-temp-buffer \(mon-buffer-exists-p \(current-buffer\) 'no-invert\)\)\n
\(pp-macroexpand-expression '\(mon-buffer-exists-p \(current-buffer\)\)\)\n
\(prog2 \(get-buffer-create \"*BAD-IF-NOT-KILLED*\"\)
\(mon-buffer-exists-p \"*BAD-IF-NOT-KILLED*\"\)
\(kill-buffer \(mon-buffer-exists-p \"*BAD-IF-NOT-KILLED*\"\)\)\)\n
\(buffer-live-p
\(prog2 \(get-buffer-create \"*BAD-IF-NOT-KILLED*\"\)
\(mon-buffer-exists-p \"*BAD-IF-NOT-KILLED*\"\)
\(kill-buffer \(mon-buffer-exists-p \"*BAD-IF-NOT-KILLED*\"\)\)\)\)\n
\(pp-macroexpand-expression '\(mon-buffer-exists-p \(buffer-name \(current-buffer\)\)\)\)\n
:ALIASED-BY `buffer-exists-p'\n
:SEE-ALSO `mon-buffer-exists-so-kill', `mon-with-file-buffer',
`mon-buffer-narrowed-p', `mon-buffer-sub-no-prop',
`mon-buffer-sub-no-prop-check', `mon-with-buffer-undo-disabled',
`mon-buffer-written-p', `mon-print-in-buffer-if-p',
`mon-buffer-name->kill-ring', `mon-get-buffer-w-mode',
`mon-get-buffer-parent-dir', `mon-get-proc-buffers-directories',
`mon-get-buffers-directories', `mon-string-split-buffer-name',
`mon-string-split-buffer-parent-dir', `with-current-buffer', `with-temp-file',
`with-temp-buffer'.\n►►►"
(declare (indent 2) (debug t))
(let ((mbep-bffr-p (make-symbol "mbep-bffr-p")))
`(let ((,mbep-bffr-p ,buffer-to-check))
(when (and ,mbep-bffr-p (buffer-live-p (get-buffer ,mbep-bffr-p)))
(if ,no-invert ,mbep-bffr-p
(case (type-of ,mbep-bffr-p)
(string (get-buffer ,mbep-bffr-p))
(buffer (buffer-name ,mbep-bffr-p))))))))
(defmacro mon-with-buffer-undo-disabled (&rest body)
"Evaluate BODY in an`buffer-disable-undo' set non-nil.\n
Arg BODY occurs inside an `unwind-protect' finishing with `buffer-enable-undo'.\n
:EXAMPLE\n
\(pp-macroexpand-expression
'\(progn
\(mon-with-buffer-undo-disabled
\(save-excursion
\(insert \"bubba\"\)\)
\(kill-line\)
\(if \(and buffer-undo-list \(atom buffer-undo-list\)\)
\(message \"Toggled buffer-undo-list %S\" buffer-undo-list\)
\(message \":BUFFER-UNDO-LIST -- fail!\" buffer-undo-list\)\)
\(sit-for 2\)\)
\(save-excursion \(insert \"I'm the bubba that got saved\"\)\)
\(kill-line\)
buffer-undo-list\)\)\n
\(mon-with-buffer-undo-disabled-TEST\)\n
\(mon-with-buffer-undo-disabled-TEST 'force-fail\)\n\n
:NOTE Useful for forms which programatically `erase-buffer' contents and the undo list
is not needed.\n
:ALIASED-BY `mon-buffer-do-with-undo-disabled'\n
:SEE-ALSO `mon-with-buffer-undo-disabled-TEST', `buffer-undo-list',
`mon-buffer-exists-p', `mon-buffer-written-p', `mon-buffer-exists-so-kill',
`mon-buffer-narrowed-p', `mon-buffer-sub-no-prop', `mon-buffer-sub-no-prop-check',
`mon-print-in-buffer-if-p', `mon-get-buffer-w-mode',
`mon-get-buffer-parent-dir', `mon-get-proc-buffers-directories',
`mon-get-buffers-directories', `mon-string-split-buffer-name',
`mon-string-split-buffer-parent-dir', `with-current-buffer', `with-temp-file',
`with-temp-buffer', `mon-help-buffer-functions'.\n►►►"
(declare (indent 2) (debug t))
`(unwind-protect
(progn
(buffer-disable-undo)
,@body)
(buffer-enable-undo)))
(defmacro mon-print-in-buffer-if-p (print-type form)
"Evalutate PRINT-TYPE with FORM in current buffer.\n
Only evaluated when buffer is visiting a file that exists, is writable, and
buffer is not read-only.\n
Otherwise, just return the printed value of form.\n
:EXAMPLE\n\n\(pp-macroexpand-expression
'\(mon-print-in-buffer-if-p 'princ \(buffer-name\)\)\)\n
:ALIASED-BY `mon-buffer-print-in-if'\n
:SEE-ALSO `mon-buffer-exists-so-kill', `mon-buffer-written-p',
`mon-buffer-exists-p', `mon-buffer-name->kill-ring', `mon-with-file-buffer',
`mon-get-buffer-parent-dir', `mon-get-proc-buffers-directories',
`mon-get-buffers-directories', `mon-string-split-buffer-name',
`mon-string-split-buffer-parent-dir'.\n►►►"
(let ((mpibip-cb (make-symbol "mpibip-cb")))
`(let ((,mpibip-cb (get-buffer (current-buffer))))
(if (and (not (buffer-local-value 'buffer-read-only ,mpibip-cb))
(buffer-file-name ,mpibip-cb)
(file-writable-p (buffer-file-name ,mpibip-cb))
(file-exists-p (buffer-file-name ,mpibip-cb)))
(funcall ,print-type ,form ,mpibip-cb)
(funcall ,print-type ,form)))))
(defmacro mon-with-inhibit-buffer-read-only (&rest uninhibited-body)
"Temporarily set value of `buffer-read-only' nil in `current-buffer'.\n
Execute the UNINHIBITED-BODY inside an `unwind-protect' form which restores value
of `buffer-read-only'.\n
:EXAMPLE\n\n\(with-current-buffer \(progn
\(describe-function 'mon-with-inhibit-buffer-read-only\)
\(get-buffer \"*Help*\"\)\)
\(mon-with-inhibit-buffer-read-only
\(sit-for 1\) \(forward-line 3\)
\(dotimes \(i 3\)
\(progn \(kill-line\) \(insert \"A LINE JUST DIED HERE\\n\"\) \(sit-for 1\)\)\)\)
\(message \"buffer-read-only value in *Help* buffer rebound -> %s\"
\(buffer-local-value 'buffer-read-only \(get-buffer \"*Help*\"\)\)\)\)\n
\(mon-with-inhibit-buffer-read-only-PP-TEST\)\n
\(mon-with-inhibit-buffer-read-only-TEST\)\n
\(mon-with-inhibit-buffer-read-only-TEST t\)\n
:SEE-ALSO `mon-inhibit-read-only', `mon-with-inhibit-buffer-read-only-TEST',
`mon-with-inhibit-buffer-read-only-PP-TEST', `mon-inhibit-modification-hooks',
`mon-inhibit-point-motion-hooks', `mon-toggle-read-only-point-motion'.\n►►►"
(declare (indent 3) (debug t))
(let ((mwibro-re-inhib (make-symbol "mwibro-re-inhib")))
`(let ((,mwibro-re-inhib (buffer-local-value buffer-read-only (current-buffer))))
(with-current-buffer (current-buffer)
(unwind-protect
(progn
(set (make-local-variable 'buffer-read-only) nil)
,@uninhibited-body)
(when ,mwibro-re-inhib (set (make-local-variable 'buffer-read-only) t)))))))
(defmacro mon-toggle-restore-llm (&optional toggle-in-buffer &rest body)
"Wrapper macro to temporarily toggle `longlines-mode' in current-buffer.\n
When optional arg TOGGLE-IN-BUFFER is non-nil check value in that buffer and
exectute BODY there. Default is `current-buffer'.
:EXAMPLE\n\n\(pp-macroexpand-expression '\(mon-naf-mode-toggle-restore-llm \"bubba\"\)\)\n
\(progn \(get-buffer-create \"*MON-TOGGLE-RESTORE-LLM-TEST*\"\)
\(pp-macroexpand-expression
'\(mon-toggle-restore-llm \"*MON-TOGGLE-RESTORE-LLM-TEST*\"
\(with-current-buffer \"*MON-TOGGLE-RESTORE-LLM-TEST*\"
\(longlines-mode\)
\(prog1 \(buffer-name\)\(kill-buffer \"*MON-TOGGLE-RESTORE-LLM-TEST*\"\)\)\)\)\)
\(display-buffer \"*Pp Macroexpand Output*\"\)\)\n
:SEE-ALSO `mon-is-naf-mode-and-llm-p', `mon-is-naf-mode-p'.\n►►►"
(declare (indent 1) (debug t))
(let ((llm-toggled (make-symbol "llm-toggled")))
`(let ((,llm-toggled
(cond (,toggle-in-buffer
(cond ((mon-is-naf-mode-p ,toggle-in-buffer)
(mon-is-naf-mode-and-llm-p ,toggle-in-buffer))
((mon-buffer-longlines-mode-p ,toggle-in-buffer))))
((not ,toggle-in-buffer)
(if (mon-is-naf-mode-p (get-buffer (current-buffer)))
(mon-is-naf-mode-and-llm-p (get-buffer (current-buffer)))
(mon-buffer-longlines-mode-p (get-buffer (current-buffer))))))))
(when ,llm-toggled
(with-current-buffer
(or ,toggle-in-buffer (get-buffer (current-buffer)))
(longlines-mode 0)))
(unwind-protect
,@body
(when ,llm-toggled
(with-current-buffer
(or ,toggle-in-buffer (get-buffer (current-buffer)))
(longlines-mode 1)))))))
(defmacro mon-naf-mode-toggle-restore-llm (&optional toggle-buffer &rest naf-body)
"Wrapper macro to temporarily toggle `longlines-mode' in `naf-mode' buffers.\n
When optional arg TOGGLE-BUFFER is non-nil check value in that buffer and
exectute BODY there. Default is `current-buffer'.
:EXAMPLE\n\n\(pp-macroexpand-expression '\(mon-naf-mode-toggle-restore-llm nil \"bubba\"\)\)\n
:SEE-ALSO `mon-toggle-restore-llm', `mon-naf-mode-toggle-restore-llm',
`mon-is-naf-mode-and-llm-p', `mon-is-naf-mode-p'.\n►►►"
(declare (indent 1) (debug t))
`(mon-toggle-restore-llm ,toggle-buffer ,@naf-body))
(defmacro* mon-line-dolines (start-end &body body)
"Executes the body with START-END `destructoring-bind'ed to the start and
end of each line of the current-buffer in turn.\n
:EXAMPLE\n\(mon-line-dolines-TEST\)\n
:SEE (URL `http://lists.gnu.org/archive/html/help-gnu-emacs/2009-12/msg00614.html')\n
:SEE-ALSO `mon-line-dolines-TEST', `mon-line-dolines-setup-TEST'.\n►►►"
(declare (indent 2) (debug t))
(let ((mld-vline (make-symbol "mld-vline"))
(mld-sm (make-symbol "mld-sm"))
(mld-em (make-symbol "mld-em")))
(destructuring-bind (start-var end-var) start-end
`(let ((,mld-sm (make-marker))
(,mld-em (make-marker)))
(unwind-protect
(save-restriction
(when (use-region-p)
(narrow-to-region (region-beginning) (region-end)))
(mon-g2be -1)
(while (< (point) (mon-g2be 1 t))
(let ((,mld-vline (point)))
(set-marker ,mld-sm (point))
(set-marker ,mld-em (goto-char (line-end-position)))
(let ((,start-var (marker-position ,mld-sm))
(,end-var (marker-position ,mld-em)))
,@body)
(goto-char ,mld-vline)
(forward-line 1))))
(set-marker ,mld-sm nil)
(set-marker ,mld-em nil))
nil))))
(defmacro mon-cat (file &optional from-psn to-psn)
"Return FILE contents as string - like `cat'.\n
When optional args FROM-PSN and TO-PSN are non-nil these specify what portion
of the file to return. Signal an error if this range is not accessible.\n
:EXAMPLE\n\n\(mon-cat \"~/.emacs\"\)\n
\(mon-cat \"~/.emacs\" 10 253\)\n
:SEE \(man \"cat\"\)
:SEE info node `(coreutils)cat invocation'\n
:SEE-ALSO `insert-file-contents'.\n►►►"
(let ((mc-fc (make-symbol "mc-fc")))
`(let ((mc-fc (with-temp-buffer
(insert-file-contents ,file nil ,from-psn ,to-psn)
(mon-buffer-sub-no-prop) )))
mc-fc)))
(provide 'mon-macs)