diff options
Diffstat (limited to 'lisp/emacs-lisp/subr-x.el')
| -rw-r--r-- | lisp/emacs-lisp/subr-x.el | 286 |
1 files changed, 169 insertions, 117 deletions
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 9529d51e40b..9cd793d05c5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -81,116 +81,6 @@ Note how the single `-' got converted into a list before threading." (declare (indent 0) (debug thread-first)) `(internal--thread-argument nil ,@forms)) - -(defsubst internal--listify (elt) - "Wrap ELT in a list if it is not one. -If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol." - (cond - ((symbolp elt) (list elt elt)) - ((null (cdr elt)) - (list (make-symbol "s") (car elt))) - (t elt))) - -(defsubst internal--check-binding (binding) - "Check BINDING is properly formed." - (when (> (length binding) 2) - (signal - 'error - (cons "`let' bindings can have only one value-form" binding))) - binding) - -(defsubst internal--build-binding-value-form (binding prev-var) - "Build the conditional value form for BINDING using PREV-VAR." - (let ((var (car binding))) - `(,var (and ,prev-var ,(cadr binding))))) - -(defun internal--build-binding (binding prev-var) - "Check and build a single BINDING with PREV-VAR." - (thread-first - binding - internal--listify - internal--check-binding - (internal--build-binding-value-form prev-var))) - -(defun internal--build-bindings (bindings) - "Check and build conditional value forms for BINDINGS." - (let ((prev-var t)) - (mapcar (lambda (binding) - (let ((binding (internal--build-binding binding prev-var))) - (setq prev-var (car binding)) - binding)) - bindings))) - -(defmacro if-let* (varlist then &rest else) - "Bind variables according to VARLIST and evaluate THEN or ELSE. -This is like `if-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 2) - (debug ((&rest [&or symbolp (symbolp form) (form)]) - body))) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (if ,(caar (last varlist)) - ,then - ,@else)) - `(let* () ,then))) - -(defmacro when-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -This is like `when-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 1) (debug if-let*)) - (list 'if-let* varlist (macroexp-progn body))) - -(defmacro and-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is non-nil." - (declare (indent 1) (debug if-let*)) - (let (res) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (when ,(setq res (caar (last varlist))) - ,@(or body `(,res)))) - `(let* () ,@(or body '(t)))))) - -;;;###autoload -(defmacro if-let (spec then &rest else) - "Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) -like \((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding." - (declare (indent 2) - (debug ([&or (symbolp form) ; must be first, Bug#48489 - (&rest [&or symbolp (symbolp form) (form)])] - body))) - (when (and (<= (length spec) 2) - (not (listp (car spec)))) - ;; Adjust the single binding case - (setq spec (list spec))) - (list 'if-let* spec then (macroexp-progn else))) - -;;;###autoload -(defmacro when-let (spec &rest body) - "Bind variables according to SPEC and conditionally evaluate BODY. -Evaluate each binding in turn, stopping if a binding value is nil. -If all are non-nil, return the value of the last form in BODY. - -The variable list SPEC is the same as in `if-let'." - (declare (indent 1) (debug if-let)) - (list 'if-let spec (macroexp-progn body))) - (defsubst hash-table-empty-p (hash-table) "Check whether HASH-TABLE is empty (has 0 elements)." (zerop (hash-table-count hash-table))) @@ -208,7 +98,9 @@ The variable list SPEC is the same as in `if-let'." (string= string "")) (defsubst string-join (strings &optional separator) - "Join all STRINGS using SEPARATOR." + "Join all STRINGS using SEPARATOR. +Optional argument SEPARATOR must be a string, a vector, or a list of +characters; nil stands for the empty string." (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -318,12 +210,6 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) -;;;###autoload -(defun string-lines (string &optional omit-nulls) - "Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results." - (split-string string "\n" omit-nulls)) - (defun string-pad (string length &optional padding start) "Pad STRING to LENGTH using PADDING. If PADDING is nil, the space character is used. If not nil, it @@ -400,6 +286,172 @@ as the new values of the bound variables in the recursive invocation." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defmacro with-memoization (place &rest code) + "Return the value of CODE and stash it in PLACE. +If PLACE's value is non-nil, then don't bother evaluating CODE +and return the value found in PLACE instead." + (declare (indent 1) (debug (gv-place body))) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + + +;;;###autoload +(defun string-pixel-width (string) + "Return the width of STRING in pixels." + (if (zerop (length string)) + 0 + ;; Keeping a work buffer around is more efficient than creating a + ;; new temporary buffer. + (with-current-buffer (get-buffer-create " *string-pixel-width*") + (delete-region (point-min) (point-max)) + (insert string) + (car (buffer-text-pixel-size nil nil t))))) + +;;;###autoload +(defun string-glyph-split (string) + "Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters." + (let ((result nil) + (start 0) + comp) + (while (< start (length string)) + (if (setq comp (find-composition-internal + start + ;; Don't search backward in the string for the + ;; start of the composition. + (min (length string) (1+ start)) + string nil)) + (progn + (push (substring string (car comp) (cadr comp)) result) + (setq start (cadr comp))) + (push (substring string start (1+ start)) result) + (setq start (1+ start)))) + (nreverse result))) + +;;;###autoload +(defun add-display-text-property (start end prop value + &optional object) + "Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer." + (let ((sub-start start) + (sub-end 0) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + (if (stringp object) + (min (length object) end) + (min end (point-max))))) + (if (not (setq disp (get-text-property sub-start 'display object))) + ;; No old properties in this range. + (put-text-property sub-start sub-end 'display (list prop value)) + ;; We have old properties. + (let ((vector nil)) + ;; Make disp into a list. + (setq disp + (cond + ((vectorp disp) + (setq vector t) + (seq-into disp 'list)) + ((not (consp (car disp))) + (list disp)) + (t + disp))) + ;; Remove any old instances. + (when-let ((old (assoc prop disp))) + (setq disp (delete old disp))) + (setq disp (cons (list prop value) disp)) + (when vector + (setq disp (seq-into disp 'vector))) + ;; Finally update the range. + (put-text-property sub-start sub-end 'display disp))) + (setq sub-start sub-end)))) + +;;;###autoload +(defun read-process-name (prompt) + "Query the user for a process and return the process object." + ;; Currently supports only the PROCESS argument. + ;; Must either return a list containing a process, or signal an error. + ;; (Returning `nil' would mean the current buffer's process.) + (unless (fboundp 'process-list) + (error "Asynchronous subprocesses are not supported on this system")) + ;; Local function to return cons of a complete-able name, and the + ;; associated process object, for use with `completing-read'. + (cl-flet ((procitem + (p) (when (process-live-p p) + (let ((pid (process-id p)) + (procname (process-name p)) + (procbuf (process-buffer p))) + (and (eq (process-type p) 'real) + (cons (if procbuf + (format "%s (%s) in buffer %s" + procname pid + (buffer-name procbuf)) + (format "%s (%s)" procname pid)) + p)))))) + ;; Perform `completing-read' for a process. + (let* ((currproc (get-buffer-process (current-buffer))) + (proclist (or (process-list) + (error "No processes found"))) + (collection (delq nil (mapcar #'procitem proclist))) + (selection (completing-read + (format-prompt prompt + (and currproc + (eq (process-type currproc) 'real) + (procitem currproc))) + collection nil :require-match nil nil + (car (seq-find (lambda (proc) + (eq currproc (cdr proc))) + collection)))) + (process (and selection + (cdr (assoc selection collection))))) + (unless process + (error "No process selected")) + process))) + +(defmacro with-buffer-unmodified-if-unchanged (&rest body) + "Like `progn', but change buffer-modified status only if buffer text changes. +If the buffer was unmodified before execution of BODY, and +buffer text after execution of BODY is identical to what it was +before, ensure that buffer is still marked unmodified afterwards. +For example, the following won't change the buffer's modification +status: + + (with-buffer-unmodified-if-unchanged + (insert \"a\") + (delete-char -1)) + +Note that only changes in the raw byte sequence of the buffer text, +as stored in the internal representation, are monitored for the +purpose of detecting the lack of changes in buffer text. Any other +changes that are normally perceived as \"buffer modifications\", such +as changes in text properties, `buffer-file-coding-system', buffer +multibyteness, etc. -- will not be noticed, and the buffer will still +be marked unmodified, effectively ignoring those changes." + (declare (debug t) (indent 0)) + (let ((hash (gensym)) + (buffer (gensym))) + `(let ((,hash (and (not (buffer-modified-p)) + (buffer-hash))) + (,buffer (current-buffer))) + (prog1 + (progn + ,@body) + ;; If we didn't change anything in the buffer (and the buffer + ;; was previously unmodified), then flip the modification status + ;; back to "unchanged". + (when (and ,hash (buffer-live-p ,buffer)) + (with-current-buffer ,buffer + (when (and (buffer-modified-p) + (equal ,hash (buffer-hash))) + (restore-buffer-modified-p nil)))))))) (provide 'subr-x) |