1 ;; Copyright (C) 2007 Vesa Karvonen
3 ;; MLton is released under a BSD-style license.
4 ;; See the file MLton-LICENSE for details.
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 ;; In Gnu Emacs, `buffer-file-truename' is abbreviated while in XEmacs it
13 ;; isn't. This isn't in compat.el, because we want to use our cached
14 ;; version of `file-truename', namely `def-use-file-truename'.
15 (defun def-use-buffer-file-truename (&rest buffer
)
16 "Returns the true filename of the current buffer."
17 (let ((name (apply (function buffer-file-name
) buffer
)))
19 (def-use-file-truename name
))))
21 (defvar def-use-file-truename-table
22 (make-hash-table :test
'equal
:weakness
'key
)
23 "Weak hash table private to `def-use-file-truename'.")
25 (defun def-use-file-truename (file)
26 "Cached version of `file-truename' combined with `abbreviate-file-name'."
27 (def-use-gethash-or-put file
31 (def-use-add-face 'font-lock-keyword-face
32 (compat-abbreviate-file-name (file-truename file
))))))
33 def-use-file-truename-table
))
35 (defun def-use-find-buffer-visiting-file (file)
36 "Tries to find a buffer visiting the specified file."
37 (let ((truename (def-use-file-truename file
)))
38 (loop for buffer in
(buffer-list) do
39 (if (with-current-buffer buffer
40 (string= (def-use-buffer-file-truename) truename
))
43 (defun def-use-find-file (file &optional other-window
)
44 "Roughly as `find-file' or `find-file-other-window' except that will not
45 open the file a second time if a buffer is editing a file by the same true
47 (let ((buffer (def-use-find-buffer-visiting-file file
)))
50 (let ((window (get-buffer-window buffer
)))
53 (switch-to-buffer-other-window buffer
))
55 (set-frame-selected-window nil window
))
57 (switch-to-buffer buffer
)))))
59 (find-file-other-window file
))
63 (defun def-use-point-at-next-line ()
64 "Returns point at the beginning of the next line."
69 (defun def-use-point-at-current-line ()
70 "Returns point at the beginning of the current line."
75 (defun def-use-current-line ()
76 "Returns the current line number counting from 1."
77 (+ 1 (count-lines 1 (def-use-point-at-current-line))))
79 (defun def-use-gethash-or-put (key_ mk-value_ table_
)
80 (or (gethash key_ table_
)
81 (puthash key_
(funcall mk-value_
) table_
)))
83 (defvar def-use-intern-table
84 (make-hash-table :test
'equal
:weakness
'key-and-value
)
85 "Weak hash table private to `def-use-intern'.")
87 (defun def-use-intern (value)
88 "Hashes the given value to itself. The assumption is that the value
89 being interned is not going to be mutated."
90 (def-use-gethash-or-put value
(function (lambda () value
))
91 def-use-intern-table
))
93 (defun def-use-hash-table-to-assoc-list (hash-table)
94 "Returns an assoc list containing all the keys and values of the hash
99 (push (cons key value
) result
)))
103 (defun def-use-hash-table-to-key-list (hash-table)
104 "Returns a list of the keys of hash-table."
105 (mapcar (function car
)
106 (def-use-hash-table-to-assoc-list hash-table
)))
108 (defun def-use-hash-table-to-value-list (hash-table)
109 "Returns a list of the values of the hash-table."
110 (mapcar (function cdr
)
111 (def-use-hash-table-to-assoc-list hash-table
)))
113 (defun def-use-set-to-list (set)
114 "Returns a list of the keys of the set (identity hash-table)."
115 (def-use-hash-table-to-key-list set
))
117 (defun def-use-make-hash-table ()
118 "Makes a hash table with `equal' semantics."
119 (make-hash-table :test
'equal
:size
1))
121 (defun def-use-kill-current-buffer ()
122 "Kills the current buffer."
124 (kill-buffer (current-buffer)))
126 (defun def-use-add-face (face string
)
127 "Adds the face as a property to the entire string and returns the
129 (add-text-properties 0 (length string
) `(face ,face
) string
)
132 (defun def-use-time-to-double (time)
133 "Converts a time to a double."
134 (+ (* (car time
) 65536.0)
136 (if (cddr time
) (* (caddr time
) 1e-06) 0)))
138 (defun def-use-attr-newer?
(attr1 attr2
)
139 "Returns non-nil iff the modification time of `attr1' is later than the
140 modification time of `attr2'. Note that this also returns nil when either
141 one of the modification times is nil."
143 (> (def-use-time-to-double (nth 5 attr1
))
144 (def-use-time-to-double (nth 5 attr2
)))))
146 (defun def-use-attr-changed?
(attr1 attr2
)
147 "Returns non-nil iff the file attributes of `attr1' are different than
148 the file attributes of `attr2'. Note that this also returns nil when either
149 one of the file attributes is nil."
150 (labels ((nequal (i) (not (equal (nth i attr1
) (nth i attr2
)))))
152 (or (def-use-attr-newer? attr1 attr2
)
154 (nequal 6) ;; status change time
155 (nequal 8) ;; file modes
159 (defun def-use-goto-line (line)
160 "Goes to specified line quietly without setting mark. By default, the
161 standard `goto-line' function in latest Gnu Emacs sets the mark displaying
162 the message \"Mark set\"."
166 (forward-line (1- line
))))
168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
170 (provide 'def-use-util
)