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 319 - (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 :     (defun custom-create-map (m bs args)
41 :     (unless (keymapp m)
42 :     (setq bs (append m bs))
43 :     (setq m (make-sparse-keymap)))
44 :     (dolist (b bs)
45 :     (let ((key (car b))
46 :     (binding (cdr b)))
47 :     (cond
48 :     ((symbolp key)
49 :     (substitute-key-definition key binding m global-map))
50 :     ((not (lookup-key m key))
51 :     (define-key m key binding)))))
52 :     (while args
53 :     (let ((key (first args))
54 :     (val (second args)))
55 :     (cond
56 :     ((eq key :inherit)
57 :     (cond
58 :     ((keymapp val) (set-keymap-parent m val))
59 :     (t (set-keymap-parents m val))))
60 :     (t (error "Uknown argument %s in defmap" key))))
61 :     (setq args (cddr args))))
62 :    
63 :     (defmacro defmap (m bs doc &rest args)
64 :     `(progn
65 :     (defvar ,m (make-sparse-keymap) ,doc)
66 :     (custom-create-map ,m ,bs ,(cons 'list args))))
67 :    
68 :     (defmacro defsyntax (st css doc &rest args)
69 :     `(defvar ,st
70 :     (let ((st (make-syntax-table ,(cadr (memq :copy args)))))
71 :     (dolist (cs ,css)
72 :     (let ((char (car cs))
73 :     (syntax (cdr cs)))
74 :     (if (sequencep char)
75 :     (mapcar* (lambda (c) (modify-syntax-entry c syntax st))
76 :     char)
77 :     (modify-syntax-entry char syntax st))))
78 :     st)
79 :     doc))
80 :    
81 :     ;;
82 :     (provide 'sml-util)

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