(provide (quote db-util)) (defmacro proclaim-inline-hack (&rest args) (byte-code "" [nil] 1)) (if (not (fboundp (quote proclaim-inline))) (fset (quote proclaim-inline) (quote proclaim-inline-hack))) (defmacro proclaim-notinline-hack (&rest args) (byte-code "" [nil] 1)) (if (not (fboundp (quote proclaim-notinline))) (fset (quote proclaim-notinline) (quote proclaim-notinline-hack))) (defun make-obsolete-hack (fn new) (byte-code "" [nil] 1)) (if (not (fboundp (quote make-obsolete))) (fset (quote make-obsolete) (quote make-obsolete-hack))) (if (not (fboundp (quote inline))) (progn (fset (quote inline) (quote progn)) (put (quote inline) (quote lisp-indent-hook) 0))) (defun byte-compile-warn-hack (&rest args) (byte-code "" [nil] 1)) (if (not (fboundp (quote byte-compile-warn))) (fset (quote byte-compile-warn) (quote byte-compile-warn-hack))) (defvar dont-fix-backquote nil) (defvar tailmaker) (defvar state) (if (or (not dont-fix-backquote) (string-match "^19" emacs-version)) (progn (require (quote backquote)) (defun bq-splicequote (form) (setq tailmaker (list form (list (quote quote) tailmaker))) (setq state (quote append))))) (if (not (fboundp (quote buffer-disable-undo))) (fset (quote buffer-disable-undo) (quote buffer-flush-undo))) (if (not (fboundp (quote frame-width))) (fset (quote frame-width) (quote screen-width))) (if (not (fboundp (quote force-mode-line-update))) (defun force-mode-line-update (&rest args) "Force the mode-line of the current buffer to be redisplayed." (set-buffer-modified-p (buffer-modified-p)))) (if (not (fboundp (quote generate-new-buffer-name))) (defun generate-new-buffer-name (name) (if (not (get-buffer name)) name (let ((count 1) (template (concat name "<%d>")) tempname) (catch (quote found) (while t (setq tempname (format template count)) (if (not (get-buffer tempname)) (throw (quote found) tempname)) (setq count (1+ count)))))))) (or (and (fboundp (quote member)) (subrp (symbol-function (quote member)))) (defun member (elt list) "like memq, but uses equal instead of eq. In v19, this is a subr." (while (and list (not (equal elt (car list)))) (setq list (cdr list))) list)) (defun db-match-string (n &optional source) "\ Return the string matched by parentheses number N. If there is a SOURCE string, return the substring of that string; else, return substring of the current buffer." (byte-code "; ! !O ! !\"" [source n t match-beginning match-end buffer-substring] 7)) (defun db-match-string-maybe (n &optional source) "\ Like db-match-string, but return nil if there was no match for parenthesis N." (byte-code "!  \"" [n source match-beginning db-match-string] 4)) (defun db-unused-char-in-buffer nil "\ Return a character not used in the current buffer, or nil. This function attempts to return a character that can be displayed in a single screen column." (byte-code " =4eb!#?0T\"=0É *)" [candidate result t nil 32 search-forward char-to-string % 256] 6)) (defun db-unused-char-in-string (string) "\ Return a character not used in STRING, or nil. This function attempts to return a character that can be displayed in a single screen column." (byte-code "!qp! c )" [string get-buffer-create " *Temporary*" buffer-disable-undo erase-buffer db-unused-char-in-buffer] 5)) (defmacro db-skip-string-forward (string) "If point is at STRING, move past it and return non-nil; otherwise return nil." (byte-code "DCE" [string let s (if (equal "" s) t (if (search-forward s (+ (point) (length s)) t) (goto-char (match-end 0))))] 3)) (defmacro db-skip-string-backward (string) "If point is after STRING, move back past it and return t; otherwise return nil." (byte-code "DCE" [string let s (if (equal "" s) t (search-backward s (- (point) (length s)) t))] 3)) (defmacro db-skip-regexp-forward (regexp &optional match-no) "If point is at REGEXP, move past it and return point; otherwise return nil. Point is left at the end of match MATCH-NO if it is specified." (byte-code "D EDDE" [regexp match-no if looking-at goto-char match-end or 0] 7)) (defmacro db-skip-regexp-backward (regexp &optional match-no) "If point is after REGEXP, move past it and return point; otherwise return nil." (byte-code "DEE" [regexp let ((here (point))) if re-search-backward (if (= here (match-end 0)) t (progn (goto-char here) nil))] 5)) (defun db-looking-back-at (PAT) "\ t when text before point matches regular expression PAT." (byte-code "e`\"Qe#))" [PAT t narrow-to-region re-search-backward "\\(" "\\)\\'"] 5)) (defmacro db-string-substitute (newchar oldchar string) "Substitute NEWCHAR for instances of OLDCHAR in STRING. NEWCHAR and OLDCHAR are characters." (byte-code " DD F" [newchar oldchar string db-string-substitute-opt regexp-quote char-to-string] 5)) (defun db-string-substitute-opt (newchar oldchar-regexp string) (byte-code " T#  I*" [i case-fold-search nil oldchar-regexp string newchar -1 string-match] 5)) (defun db-string-substitute-substring-general-case (new old-regexp string) "\ Call `string-replace-regexp-2'. Beware special meaning of \\!." (byte-code " #" [string old-regexp new string-replace-regexp-2] 4)) (defun string-replace-regexp-2 (string regexp replacement) "\ Return the string resulting by replacing all of STRING's instances of REGEXP with REPLACEMENT." (byte-code "!qp! ceb #\" ! )" [string regexp nil t replacement get-buffer-create " *Temporary*" buffer-disable-undo erase-buffer re-search-forward replace-match buffer-string] 7)) (defun db-how-many-string-overlapping (string) "\ Return number of matches for STRING following point, including overlapping ones." (byte-code " #!TbT))" [count string nil t 0 search-forward match-beginning] 5)) (defun db-how-many-substring-overlapping (substring target) "\ Return number of matches for SUBSTRING in TARGET, including overlapping ones." (byte-code " ! T# T +" [ss-regexp substring count start target regexp-quote 0 -1 string-match] 5)) (defun db-find-char (char string &optional count) "\ Look for CHAR in STRING; return first index in STRING whose element is CHAR. If optional arg COUNT is specified, return the COUNTth occurrance." (byte-code "?lj G W ?> H\"5U1 5S T +" [count index string-length string result nil char 1 0 char-equal] 5)) (defun db-find-char-from-end (char string &optional count) "\ Look for CHAR in STRING; return last index in STRING whose element is CHAR. If optional arg COUNT is specified, return the COUNTth occurrance from the end." (byte-code "?lj GS V ?? H\"6U2 6S S +" [count index string string-length nil result char 1 -1 char-equal] 5)) (defun db-string-trim-whitespace (string) "\ Return a substring of STRING with whitespace removed from beginning and end." (byte-code "\"\"Ň" [string string-match "\\s *\\(.*[^ ]\\)\\s *" db-match-string 1 ""] 4)) (proclaim-inline db-string-trim-whitespace) (defvar def-db-struct-concatenator "-" "\ Inserted between the struct and slot names in slot accessors and setters. Typical values are \"-\" and \"\".") (defmacro def-db-struct (name &rest slots) "Define NAME as a structure type with a slot for each additional argument. NAME is a symbol, the name of the new structure, and each slotname is a symbol. This macro defines functions `make-NAME', `NAME-p', and `copy-NAME' for the structure, and functions `NAME-SLOTNAME' and `NAME-set-SLOTNAME' to access and set slots. It also sets variable NAME-length to the number of slots. NAME may also be a list (struct-name (option-name option-value) ...), where each option-name is a keyword symbol in {:constructor :predicate :copier} and option-value is a symbol, the name that should be used for that function instead of the defaults listed above." (byte-code " G   <* A @  ! P @!P! @!Q! FF %FDFDFF\" A T5 \"A@  !Q! \"A@ P! \"A@  !Q!  P! E TEDC DFFFDF F DF  !Q TE DEF%&\"B. " [body i L slots conc-name options name1 name2 makename predname copyname name def-db-struct-concatenator nil 1 symbol-name intern "set-" nconc defmacro (vector) list (quote aref) vector (vector value) (quote aset) value put quote (quote edebug-form-hook) (quote (form)) (quote edebug-form-hook) (quote (form form)) assoc :constructor "make" :predicate "p" :copier "copy" defconst "length" defun let result make-vector aset 0 (quote edebug-form-hook) (quote nil) (struct) (list (quote copy-sequence) struct) (quote edebug-form-hook) (quote (form)) (object) "T if OBJECT is a " "." and (vectorp object) = (length object) eq (aref object 0) progn] 37)) (put (quote def-db-struct) (quote edebug-form-spec) (quote (&rest form))) (defun db-add-to-hook (hook-var &rest items) "\ Add to HOOK one or more FUNCTIONS as correctly as possible. HOOK evaluates to a symbol. This is designed to work only with hooks that are run by run-hooks. Because of run-hooks flexibility, the value a hook has can take a variety of forms. This function tries to deal with all of those forms. If you find a case it does not handle, please tell me. After this function is done, the hook variable is a list with each element one function to be run, regardless of what form the value of the hook took before." (byte-code "9!!LJ 9 * :* @=1 C :P @ >G B A2 L*" [hook-var nil hook-value item items error "first argument must be symbol" boundp lambda] 5)) (defmacro deflocalvar (&rest args) "Like defvar, but defines a buffer-local variable." (byte-code "\"@DDE" [args progn append (defvar) make-variable-buffer-local quote] 6)) (put (quote deflocalvar) (quote edebug-form-spec) (quote (&rest form))) (defmacro db-meta-prefix-ify (keys) "Prepend `meta-prefix-char' to KEYS, a string." (byte-code "E" [keys concat (list meta-prefix-char)] 3)) (defun db-functionp (object) "\ Return t if OBJECT is a function (is funcallable), nil otherwise." (byte-code "9!K!*<*@=*A@<" [object fboundp subrp lambda] 4)) (proclaim-inline db-functionp) (defun db-funcall-maybe (fun &rest args) "\ If FUN is non-nil, apply it to ARGS. Otherwise return second argument, which would have been the first argument to which FUN was applied. FUN should be a funcallable object or nil. Compare to `db-maybe-funcall'." (byte-code "  \"  @" [fun args apply] 3)) (put (quote db-funcall-maybe) (quote edebug-form-spec) (quote (function &rest form))) (defun db-funcall-maybe-default (default fun &rest args) "\ If FUN is non-nil, apply it to ARGS. Otherwise return DEFAULT. FUN should be a funcallable object or nil." (byte-code "  \" " [fun args default apply] 3)) (put (quote db-funcall-maybe-default) (quote edebug-form-spec) (quote (form function &rest form))) (defmacro db-maybe-funcall (fun &rest args) "If FUN is non-nil, apply it to ARGS. Otherwise return nil. FUN should be a funcallable object or nil. Compare to `db-funcall-maybe'." (byte-code "D #" [fun args append (db-funcall-maybe-default) nil] 4)) (put (quote db-maybe-funcall) (quote edebug-form-spec) (quote (function &rest form))) (defmacro db-vararg-call (func noargs1 noargs2 &rest args) "Apply FUNC to NOARGS1 (an integer), then (if that fails), to NOARGS2 of the ARGS. -1 means all arguments. This macro lets you deal with functions expecting different numbers of arguments in a uniform way. Since this is a macro, don't supply something of the form (function foo) as its first argument; just supply foo itself." (byte-code " GW[W'[]U?I ]$] \"^Ua B WT!P! B @D B Aa ! !  C W # C W #D%E." [noargs args nocommon-args common-vars common-bindings thisvar thisargno noargs1 noargs2 func nil 0 byte-compile-warn "`%s' was db-vararg-called with a maximum of %d arguments, but you supplied %d." firstn make-symbol "vararg-common-" int-to-string nreverse let list condition-case err append wrong-number-of-arguments (error (while t (signal (car err) (cdr err))))] 19)) (defvar db-filename-extension-regexp "[^.]\\(\\.\\([-a-z]*\\)\\)$" "\ Submatch 1 is the extension with leading period; submatch 2 is without.") (defun db-filename-sans-extension (filename) (byte-code " \" !O " [db-filename-extension-regexp filename string-match 0 match-beginning 1] 5)) (defun db-if-file-readable-p (filename) "\ Return FILENAME if the file is readable, nil otherwise." (byte-code "!" [filename file-readable-p] 2)) (proclaim-inline db-if-file-readable-p) (defun db-locate-file-with-extensions (filename extensions) "\ Return the name of a readable file starting with FILENAME or FILENAME's basename and ending with a string in EXTENSIONS, which is a list. EXTENSIONS may be nil, in which case FILENAME is searched for as is." (byte-code "/ ?) @P! !@P!A )2 !" [extensions result filename nil db-if-file-readable-p db-filename-sans-extension] 6)) (defun db-locate-file-with-extensions-on-path (filename extensions path) "\ Return the name of a readable file starting with FILENAME or FILENAME's basename and ending with a string in EXTENSIONS, which is a list. PATH is a list of strings representing directories to be searched in order after the current one; they may be relative directories. Nil means the current directory." (byte-code " \"O!! ?L@+@!-A !@ PD Q \" ," [filename extensions filename-directory filename-nondirectory result candidate-directory path default-directory db-locate-file-with-extensions file-name-directory file-name-nondirectory nil file-name-as-directory file-name-absolute-p] 10)) (defun db-locate-file-on-path (filename path) "\ Return the full path of a file named FILENAME located in the current directory or on PATH, which is a list of directories (strings) or nil for the current directory." (byte-code " #" [filename nil path db-locate-file-with-extensions-on-path] 4)) (defun db-file-resolve-symlink (file) "\ Return the non-link FILE eventually points to, or FILE if it's not a symbolic link. This gets in an infinite loop if FILE points into a circular list of symlinks." (byte-code "!!@!\"" [file file-symlink-p expand-file-name file-attributes file-name-directory] 7)) (defun db-same-file-p (file1 file2) "\ Return t if FILE1 and FILE2 are names for the same file." (byte-code "! ! \"7 !\"7 !\"7!7 !7! !\"" [file1 file2 db-file-resolve-symlink equal file-name-nondirectory file-exists-p file-attributes] 14)) (defun string->integer-default (string &optional default) "\ If STRING represents an integer, return it; otherwise return DEFAULT." (byte-code "ď! )" [result default nil (byte-code "!@" [string read-from-string] 2) ((error (byte-code "" [nil] 1))) integerp] 3)) (fset (quote string->number-default) (symbol-function (quote string->integer-default))) (defun string->integer-or-nil (string) (byte-code "\"" [string nil string->integer-default] 3)) (fset (quote string->number-or-nil) (symbol-function (quote string->integer-or-nil))) (defun string->integer (string) "\ Return the integer represented by STRING, or err. See also `string->integer-default'." (byte-code "! \"" [string string->integer-or-nil error "string->integer: `%s' doesn't look like an integer."] 4)) (fset (quote string->number) (symbol-function (quote string->integer))) (defun number-or-nil->string (number) (byte-code "! ! Ç" [number numberp int-to-string ""] 3)) (make-obsolete (quote integer-or-nil->string) (quote number-or-nil->string)) (defmacro in-buffer (buffer &rest body) "Executes, in BUFFER, forms of BODY." (byte-code "DDD \" \"EEEEFE" [buffer body let target-buffer get-buffer-create (this-buffer (current-buffer)) if (eq target-buffer this-buffer) append (progn) unwind-protect progn (set-buffer target-buffer) let* ((target-window (get-buffer-window target-buffer)) (track-window-point-p (and (not (eq target-window (selected-window))) (eq (window-point target-window) (point))))) prog1 (progn) (if (and track-window-point-p (eq (current-buffer) target-buffer) (eq target-window (get-buffer-window target-buffer)) (not (eq target-window (selected-window)))) (set-window-point target-window (point))) (if (and (bufferp this-buffer) (buffer-name this-buffer)) (set-buffer this-buffer))] 15)) (put (quote in-buffer) (quote lisp-indent-hook) 1) (put (quote in-buffer) (quote edebug-form-spec) (quote (&rest form))) (defmacro in-window (window &rest body) "Executes, in WINDOW, forms of BODY. This is more useful than `in-buffer' for window manipulation, as by `scroll-up'." (byte-code "DD \"EE" [window body let ((this-window (selected-window))) unwind-protect append progn select-window (select-window this-window)] 7)) (put (quote in-window) (quote lisp-indent-hook) 1) (put (quote in-window) (quote edebug-form-spec) (quote (&rest form))) (defun db-copy-buffer-local-variables (buffer) "\ Copy the values of all of BUFFER's local variables into the current buffer." (byte-code " !p = Kˎ q ! =?' !`= Ap =A !=A =?H `\"*)*:@@>pȂx9?!!ALAS+" [blv target-buffer buffer this-buffer target-window track-window-point-p pair symbol nil get-buffer-create buffer-local-variables ((byte-code "! !q" [this-buffer bufferp buffer-name] 3)) get-buffer-window selected-window window-point set-window-point (0 buffer-undo-list) error "impossible" make-local-variable] 14)) (defun eob-visible-p nil (byte-code " !Z! m))" [ht window-height selected-window move-to-window-line 2 end-of-line] 5)) (defun bob-visible-p nil (byte-code "! o)" [move-to-window-line 0 beginning-of-line] 3)) (defun db-string-split-last-word (splitee &optional exceptions delimiter) "\ Return list of two strings (all-but-last-word last-word). If there is only one word, return (SPLITEE \"\"). The result strings can be concatenated to return the original string, with the exception of some number (at least one) of spaces and tabs, and possibly a comma immediately preceding them. Optional arg EXCEPTIONS, if non-nil, is a regexp (containing spaces or tabs) which, if found at the end of SPLITEE, should be considered a single word. Optional arg DELIMITER, if non-nil, is used instead of the default word delimiter. It should be a regexp." (byte-code "?É  R \"P \"1 !O !OD4 D" [delimiter exceptions splitee ",?[ ]+" string-match "\\(" "\\)$" "\\([a-zA-Z0-9'-]+\\)$" 0 match-beginning 1 nil ""] 8)) (defun db-string-split-first-word (splitee &optional delimiter) "\ Return list of strings (first-word remaining-words). Argument SPLITEE is split at the first sequence of spaces and tabs. Optional arg DELIMITER, if non-nil, is used instead of the default word delimiter. It should be a regexp." (byte-code " \" !O !OD D" [delimiter splitee string-match "[ ]+" 0 match-beginning match-end nil ""] 7)) (defun count-array (item array) "\ Return the number of times that ITEM appears in ARRAY; test with `equal'." (byte-code " G W# H\" T T +" [limit array result index item 0 equal] 5)) (defun firstn (n list) "\ Return a copy of the first N elements of LIST." (byte-code " V @B S A!)" [result list n nil 0 nreverse] 3)) (defun db-rassoc (elt list) "\ Return non-nil if ELT is the cdr of an element of LIST. Comparison done with `equal'. The value is actually the element of LIST whose cdr is ELT." (byte-code " @A\" @É A)" [result list elt nil equal] 4)) (defvar use-electric-help-p nil "\ *Non-nil if Emacs programs should use electric help where possible. Don't set this to a non-nil value unless the ehelp package is available.") (defmacro with-electric-help-maybe (&rest body) "Similar to `with-electric-help' if `use-electric-help-p' is non-nil; otherwise like `with-output-to-temp-buffer' with the \"*Help*\" buffer. Ehelp is loaded if necessary. BODY is not a thunk (a function of no arguments) but simply a set of forms." (byte-code "\"DDE\"F" [body if use-electric-help-p progn (require (quote ehelp)) with-electric-help function append (lambda nil) (with-output-to-temp-buffer "*Help*")] 9)) (defun db-best-fit-message (text &optional buffer) "\ Show TEXT in echo area if it fits or in optional BUFFER (default *Message*)." (byte-code "ĉ!q p! c`!`\"i W-!o@!!ed\"\"T N!!Tא !)" [buffer text t use-electric-help-p "*Message*" get-buffer-create " temp printing buffer" erase-buffer buffer-disable-undo delete-region skip-chars-backward " " frame-width beginning-of-line 1 delete-windows-on message "%s" buffer-substring require ehelp with-electric-help (lambda nil (byte-code "!" [text princ] 2)) "*Help*" princ] 16)) (defun db-forward-line-wrapping (arg) "\ Like forward-line, but wrap around to the beginning of the buffer if it encounters the end." (interactive "p") (byte-code "ˆ !Vn?eb!'W'dbT!)" [to-go arg nil forward-line 0 db-forward-line-wrapping] 4)) (defun db-current-line nil "\ Return the line number of the line containing point." (byte-code " `\"T))" [widen beginning-of-line count-lines 1] 5)) (defun buffer-substitute (substitutions backward check) (byte-code " !\" ] @@ @Aeb0 #: @eb \" T`eU?P Blj A ," [backward substitutions from-string to-string ambiguity ambiguities check nil t mapcar (lambda (sub-cons) (byte-code "A@B" [sub-cons] 2)) reverse search-forward replace-string] 7)) (defun db-operate-on-local-variables (region-function) "\ Apply REGION-FUNCTION to the local-variables region of the buffer. Return t if a local-variables region was found; REGION-FUNCTION should act by side effect." (byte-code "dbdZe]## ! `d#" [nil t region-function search-backward " " 3000 move search-forward "Local Variables:" beginning-of-line 1 funcall] 7)) (defun db-really-hack-local-variables nil "\ Call `hack-local-variables', ignoring variables that limit it." (byte-code " +" [ignore-local-eval nil enable-local-eval t inhibit-local-variables hack-local-variables] 3))