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 332 - (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 332 ;;;
41 :     ;;; temp files
42 :     ;;;
43 :    
44 :     (defvar temp-file-dir temporary-file-directory
45 :     "Directory where to put temp files.")
46 :    
47 :     (defvar temp-directories ())
48 :    
49 :     (defun delete-temp-dirs ()
50 :     (dolist (dir temp-directories)
51 :     (when (file-directory-p dir)
52 :     (let ((default-directory dir))
53 :     (dolist (file (directory-files "."))
54 :     (ignore-errors (delete-file file))))
55 :     (delete-directory dir))))
56 :     (add-hook 'kill-emacs-hook 'delete-temp-dirs)
57 :    
58 :     (defun make-temp-dir (s)
59 :     (let* ((prefix (expand-file-name s temp-file-dir))
60 :     (dir (make-temp-name prefix)))
61 :     (if (not (ignore-errors (make-directory dir t) t))
62 :     (make-temp-dir prefix)
63 :     (push dir temp-directories)
64 :     dir)))
65 :    
66 :     (defun make-temp-file (s)
67 :     (unless (file-name-absolute-p s)
68 :     (unless (equal (user-uid)
69 :     (third (file-attributes temporary-file-directory)))
70 :     (setq temporary-file-directory (make-temp-dir "emacs")))
71 :     (setq s (expand-file-name s temporary-file-directory)))
72 :     (let ((file (make-temp-name s)))
73 :     (write-region 1 1 file nil 'silent)
74 :     file))
75 :    
76 :     ;; defmap ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77 :    
78 : monnier 319 (defun custom-create-map (m bs args)
79 :     (unless (keymapp m)
80 :     (setq bs (append m bs))
81 :     (setq m (make-sparse-keymap)))
82 :     (dolist (b bs)
83 :     (let ((key (car b))
84 :     (binding (cdr b)))
85 :     (cond
86 :     ((symbolp key)
87 :     (substitute-key-definition key binding m global-map))
88 : monnier 332 ((let ((o (lookup-key m key))) (or (null o) (numberp o)))
89 : monnier 319 (define-key m key binding)))))
90 :     (while args
91 :     (let ((key (first args))
92 :     (val (second args)))
93 :     (cond
94 :     ((eq key :inherit)
95 :     (cond
96 :     ((keymapp val) (set-keymap-parent m val))
97 :     (t (set-keymap-parents m val))))
98 :     (t (error "Uknown argument %s in defmap" key))))
99 : monnier 332 (setq args (cddr args)))
100 :     m)
101 : monnier 319
102 :     (defmacro defmap (m bs doc &rest args)
103 : monnier 332 `(defconst ,m
104 :     (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
105 :     ,doc))
106 : monnier 319
107 : monnier 332 ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
108 :    
109 :     (defun custom-create-syntax (css args)
110 :     (let ((st (make-syntax-table (cadr (memq :copy args)))))
111 :     (dolist (cs css)
112 :     (let ((char (car cs))
113 :     (syntax (cdr cs)))
114 :     (if (sequencep char)
115 :     (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
116 :     (modify-syntax-entry char syntax st))))
117 :     st))
118 :    
119 : monnier 319 (defmacro defsyntax (st css doc &rest args)
120 : monnier 332 `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
121 : monnier 319
122 :     ;;
123 :     (provide 'sml-util)

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