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 332, Tue Jun 15 00:51:38 1999 UTC
# Line 37  Line 37 
37            (flatten head rest)            (flatten head rest)
38          (cons head rest)))))          (cons head rest)))))
39    
40    ;;;
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  (defun custom-create-map (m bs args)  (defun custom-create-map (m bs args)
79    (unless (keymapp m)    (unless (keymapp m)
80      (setq bs (append m bs))      (setq bs (append m bs))
# Line 47  Line 85 
85        (cond        (cond
86         ((symbolp key)         ((symbolp key)
87          (substitute-key-definition key binding m global-map))          (substitute-key-definition key binding m global-map))
88         ((not (lookup-key m key))         ((let ((o (lookup-key m key))) (or (null o) (numberp o)))
89          (define-key m key binding)))))          (define-key m key binding)))))
90    (while args    (while args
91      (let ((key (first args))      (let ((key (first args))
# Line 58  Line 96 
96           ((keymapp val) (set-keymap-parent m val))           ((keymapp val) (set-keymap-parent m val))
97           (t (set-keymap-parents m val))))           (t (set-keymap-parents m val))))
98         (t (error "Uknown argument %s in defmap" key))))         (t (error "Uknown argument %s in defmap" key))))
99      (setq args (cddr args))))      (setq args (cddr args)))
100      m)
101    
102  (defmacro defmap (m bs doc &rest args)  (defmacro defmap (m bs doc &rest args)
103    `(progn    `(defconst ,m
104       (defvar ,m (make-sparse-keymap) ,doc)       (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
105       (custom-create-map ,m ,bs ,(cons 'list args))))       ,doc))
106    
107  (defmacro defsyntax (st css doc &rest args)  ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
108    `(defvar ,st  
109       (let ((st (make-syntax-table ,(cadr (memq :copy args)))))  (defun custom-create-syntax (css args)
110         (dolist (cs ,css)    (let ((st (make-syntax-table (cadr (memq :copy args)))))
111        (dolist (cs css)
112           (let ((char (car cs))           (let ((char (car cs))
113                 (syntax (cdr cs)))                 (syntax (cdr cs)))
114             (if (sequencep char)             (if (sequencep char)
115                 (mapcar* (lambda (c) (modify-syntax-entry c syntax st))              (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
                         char)  
116               (modify-syntax-entry char syntax st))))               (modify-syntax-entry char syntax st))))
117         st)      st))
118       doc))  
119    (defmacro defsyntax (st css doc &rest args)
120      `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
121    
122  ;;  ;;
123  (provide 'sml-util)  (provide 'sml-util)

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

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