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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 319, Mon Jun 7 22:47:00 1999 UTC revision 341, Fri Jun 18 19:10:12 1999 UTC
# Line 37  Line 37 
37            (flatten head rest)            (flatten head rest)
38          (cons head rest)))))          (cons head rest)))))
39    
40    (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    ;;;
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      "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      (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          (file-name-as-directory dir))))
81    
82    (defun make-temp-file (s)
83      "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      (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  (defun custom-create-map (m bs args)  (defun custom-create-map (m bs args)
99      (let (inherit dense)
100        (while args
101          (let ((key (first args))
102                (val (second args)))
103            (cond
104             ((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)    (unless (keymapp m)
109      (setq bs (append m bs))      (setq bs (append m bs))
110      (setq m (make-sparse-keymap)))        (setq m (if dense (make-keymap) (make-sparse-keymap))))
111    (dolist (b bs)    (dolist (b bs)
112      (let ((key (car b))      (let ((key (car b))
113            (binding (cdr b)))            (binding (cdr b)))
114        (cond        (cond
115         ((symbolp key)         ((symbolp key)
116          (substitute-key-definition key binding m global-map))          (substitute-key-definition key binding m global-map))
117         ((not (lookup-key m key))           ((let ((o (lookup-key m key))) (or (null o) (numberp o)))
118          (define-key m key binding)))))          (define-key m key binding)))))
   (while args  
     (let ((key (first args))  
           (val (second args)))  
119        (cond        (cond
120         ((eq key :inherit)       ((keymapp inherit) (set-keymap-parent m inherit))
121          (cond       ((consp inherit) (set-keymap-parents m inherit)))
122           ((keymapp val) (set-keymap-parent m val))      m))
          (t (set-keymap-parents m val))))  
        (t (error "Uknown argument %s in defmap" key))))  
     (setq args (cddr args))))  
123    
124  (defmacro defmap (m bs doc &rest args)  (defmacro defmap (m bs doc &rest args)
125    `(progn    `(defconst ,m
126       (defvar ,m (make-sparse-keymap) ,doc)       (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
127       (custom-create-map ,m ,bs ,(cons 'list args))))       ,doc))
128    
129  (defmacro defsyntax (st css doc &rest args)  ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130    `(defvar ,st  
131       (let ((st (make-syntax-table ,(cadr (memq :copy args)))))  (defun custom-create-syntax (css args)
132         (dolist (cs ,css)    (let ((st (make-syntax-table (cadr (memq :copy args)))))
133        (dolist (cs css)
134           (let ((char (car cs))           (let ((char (car cs))
135                 (syntax (cdr cs)))                 (syntax (cdr cs)))
136             (if (sequencep char)             (if (sequencep char)
137                 (mapcar* (lambda (c) (modify-syntax-entry c syntax st))              (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
                         char)  
138               (modify-syntax-entry char syntax st))))               (modify-syntax-entry char syntax st))))
139         st)      st))
140       doc))  
141    (defmacro defsyntax (st css doc &rest args)
142      `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
143    
144  ;;  ;;
145  (provide 'sml-util)  (provide 'sml-util)

Legend:
Removed from v.319  
changed lines
  Added in v.341

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