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 535 - (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 : monnier 535 ;;; defmap
54 : monnier 332 ;;;
55 :    
56 : monnier 319 (defun custom-create-map (m bs args)
57 : monnier 535 (let (inherit dense suppress)
58 : monnier 341 (while args
59 :     (let ((key (first args))
60 :     (val (second args)))
61 : monnier 319 (cond
62 : monnier 341 ((eq key :dense) (setq dense val))
63 :     ((eq key :inherit) (setq inherit val))
64 : monnier 535 ((eq key :group) )
65 :     ;;((eq key :suppress) (setq suppress val))
66 : monnier 341 (t (message "Uknown argument %s in defmap" key))))
67 :     (setq args (cddr args)))
68 :     (unless (keymapp m)
69 :     (setq bs (append m bs))
70 :     (setq m (if dense (make-keymap) (make-sparse-keymap))))
71 :     (dolist (b bs)
72 : monnier 535 (let ((keys (car b))
73 : monnier 341 (binding (cdr b)))
74 : monnier 535 (dolist (key (if (consp keys) keys (list keys)))
75 :     (cond
76 :     ((symbolp key)
77 :     (substitute-key-definition key binding m global-map))
78 :     ((null binding)
79 :     (unless (keymapp (lookup-key m key)) (define-key m key binding)))
80 :     ((let ((o (lookup-key m key)))
81 :     (or (null o) (numberp o) (eq o 'undefined)))
82 :     (define-key m key binding))))))
83 : monnier 341 (cond
84 :     ((keymapp inherit) (set-keymap-parent m inherit))
85 :     ((consp inherit) (set-keymap-parents m inherit)))
86 :     m))
87 : monnier 319
88 :     (defmacro defmap (m bs doc &rest args)
89 : monnier 332 `(defconst ,m
90 :     (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
91 :     ,doc))
92 : monnier 319
93 : monnier 332 ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 :    
95 :     (defun custom-create-syntax (css args)
96 :     (let ((st (make-syntax-table (cadr (memq :copy args)))))
97 :     (dolist (cs css)
98 :     (let ((char (car cs))
99 :     (syntax (cdr cs)))
100 :     (if (sequencep char)
101 :     (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
102 :     (modify-syntax-entry char syntax st))))
103 :     st))
104 :    
105 : monnier 319 (defmacro defsyntax (st css doc &rest args)
106 : monnier 332 `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
107 : monnier 319
108 : monnier 535 ;;;;
109 :     ;;;; Compatibility info
110 :     ;;;;
111 :    
112 :     (defvar sml-builtin-nested-comments-flag
113 :     (ignore-errors
114 :     (not (equal (let ((st (make-syntax-table)))
115 :     (modify-syntax-entry ?\* ". 23n" st) st)
116 :     (let ((st (make-syntax-table)))
117 :     (modify-syntax-entry ?\* ". 23" st) st))))
118 :     "Whether this Emacs understands the `n' in syntax entries.")
119 :    
120 : monnier 319 ;;
121 :     (provide 'sml-util)

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