Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/sml-mode/sml-util.el
ViewVC logotype

Annotation of /sml/trunk/sml-mode/sml-util.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 341 - (view) (download)

1 : monnier 319 ;;; sml-util.el
2 :    
3 :     (defconst rcsid-sml-util "@(#)$Name$:$Id$")
4 :    
5 :     ;; Copyright (C) 1999-1999 Stefan Monnier <monnier@cs.yale.edu>
6 :     ;;
7 :     ;; This program is free software; you can redistribute it and/or modify
8 :     ;; it under the terms of the GNU General Public License as published by
9 :     ;; the Free Software Foundation; either version 2 of the License, or
10 :     ;; (at your option) any later version.
11 :     ;;
12 :     ;; This program is distributed in the hope that it will be useful,
13 :     ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     ;; GNU General Public License for more details.
16 :     ;;
17 :     ;; You should have received a copy of the GNU General Public License
18 :     ;; along with this program; if not, write to the Free Software
19 :     ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 :    
21 :     (require 'cl)
22 :     (require 'sml-compat)
23 :    
24 :     ;;
25 :    
26 :     (defmacro concatq (&rest ss)
27 :     "Concatenate all the arguments and make the result a string.
28 :     As opposed to `concat', `concatq' does not evaluate its arguments
29 :     and is hence executed at macro-expansion-time."
30 :     (apply 'concat ss))
31 :    
32 :     (defun flatten (ls &optional acc)
33 :     (if (null ls) acc
34 :     (let ((rest (flatten (cdr ls) acc))
35 :     (head (car ls)))
36 :     (if (listp head)
37 :     (flatten head rest)
38 :     (cons head rest)))))
39 :    
40 : monnier 334 (defun sml-preproc-alist (al)
41 :     "Expand an alist where keys can be lists of keys into a normal one."
42 :     (reduce (lambda (x al)
43 :     (let ((k (car x))
44 :     (v (cdr x)))
45 :     (if (consp k)
46 :     (append (mapcar (lambda (y) (cons y v)) k) al)
47 :     (cons x al))))
48 :     al
49 :     :initial-value nil
50 :     :from-end t))
51 :    
52 : monnier 332 ;;;
53 :     ;;; temp files
54 :     ;;;
55 :    
56 :     (defvar temp-file-dir temporary-file-directory
57 :     "Directory where to put temp files.")
58 :    
59 :     (defvar temp-directories ())
60 :    
61 :     (defun delete-temp-dirs ()
62 :     (dolist (dir temp-directories)
63 :     (when (file-directory-p dir)
64 :     (let ((default-directory dir))
65 :     (dolist (file (directory-files "."))
66 :     (ignore-errors (delete-file file))))
67 :     (delete-directory dir))))
68 :     (add-hook 'kill-emacs-hook 'delete-temp-dirs)
69 :    
70 :     (defun make-temp-dir (s)
71 : monnier 334 "Create a temporary directory.
72 :     The returned dir name (created by appending some random characters at the end
73 :     of S and prepending `temporary-file-directory' if it is not already absolute)
74 :     is guaranteed to point to a newly created empty directory."
75 : monnier 332 (let* ((prefix (expand-file-name s temp-file-dir))
76 :     (dir (make-temp-name prefix)))
77 :     (if (not (ignore-errors (make-directory dir t) t))
78 :     (make-temp-dir prefix)
79 :     (push dir temp-directories)
80 : monnier 334 (file-name-as-directory dir))))
81 : monnier 332
82 :     (defun make-temp-file (s)
83 : monnier 334 "Create a temporary file.
84 :     The returned file name (created by appending some random characters at the end
85 :     of S and prepending `temporary-file-directory' if it is not already absolute)
86 :     is guaranteed to point to a newly created empty file."
87 : monnier 332 (unless (file-name-absolute-p s)
88 :     (unless (equal (user-uid)
89 :     (third (file-attributes temporary-file-directory)))
90 :     (setq temporary-file-directory (make-temp-dir "emacs")))
91 :     (setq s (expand-file-name s temporary-file-directory)))
92 :     (let ((file (make-temp-name s)))
93 :     (write-region 1 1 file nil 'silent)
94 :     file))
95 :    
96 :     ;; defmap ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
97 :    
98 : monnier 319 (defun custom-create-map (m bs args)
99 : monnier 341 (let (inherit dense)
100 :     (while args
101 :     (let ((key (first args))
102 :     (val (second args)))
103 : monnier 319 (cond
104 : monnier 341 ((eq key :dense) (setq dense val))
105 :     ((eq key :inherit) (setq inherit val))
106 :     (t (message "Uknown argument %s in defmap" key))))
107 :     (setq args (cddr args)))
108 :     (unless (keymapp m)
109 :     (setq bs (append m bs))
110 :     (setq m (if dense (make-keymap) (make-sparse-keymap))))
111 :     (dolist (b bs)
112 :     (let ((key (car b))
113 :     (binding (cdr b)))
114 :     (cond
115 :     ((symbolp key)
116 :     (substitute-key-definition key binding m global-map))
117 :     ((let ((o (lookup-key m key))) (or (null o) (numberp o)))
118 :     (define-key m key binding)))))
119 :     (cond
120 :     ((keymapp inherit) (set-keymap-parent m inherit))
121 :     ((consp inherit) (set-keymap-parents m inherit)))
122 :     m))
123 : monnier 319
124 :     (defmacro defmap (m bs doc &rest args)
125 : monnier 332 `(defconst ,m
126 :     (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
127 :     ,doc))
128 : monnier 319
129 : monnier 332 ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130 :    
131 :     (defun custom-create-syntax (css args)
132 :     (let ((st (make-syntax-table (cadr (memq :copy args)))))
133 :     (dolist (cs css)
134 :     (let ((char (car cs))
135 :     (syntax (cdr cs)))
136 :     (if (sequencep char)
137 :     (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
138 :     (modify-syntax-entry char syntax st))))
139 :     st))
140 :    
141 : monnier 319 (defmacro defsyntax (st css doc &rest args)
142 : monnier 332 `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
143 : monnier 319
144 :     ;;
145 :     (provide 'sml-util)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0