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 541 - (view) (download)

1 : monnier 541 ;;; sml-util.el --- Utility functions for sml-mode
2 : monnier 319
3 : monnier 541 ;; Copyright (C) 1999-2000 Stefan Monnier <monnier@cs.yale.edu>
4 : monnier 319 ;;
5 :     ;; This program is free software; you can redistribute it and/or modify
6 :     ;; it under the terms of the GNU General Public License as published by
7 :     ;; the Free Software Foundation; either version 2 of the License, or
8 :     ;; (at your option) any later version.
9 :     ;;
10 :     ;; This program is distributed in the hope that it will be useful,
11 :     ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 :     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 :     ;; GNU General Public License for more details.
14 :     ;;
15 :     ;; You should have received a copy of the GNU General Public License
16 :     ;; along with this program; if not, write to the Free Software
17 :     ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18 :    
19 : monnier 541
20 :     ;;; Commentary:
21 :    
22 :     ;;; Code:
23 :    
24 :     (require 'cl) ;for `reduce'
25 : monnier 319 (require 'sml-compat)
26 :    
27 :     ;;
28 :    
29 :     (defun flatten (ls &optional acc)
30 :     (if (null ls) acc
31 :     (let ((rest (flatten (cdr ls) acc))
32 :     (head (car ls)))
33 :     (if (listp head)
34 :     (flatten head rest)
35 :     (cons head rest)))))
36 :    
37 : monnier 334 (defun sml-preproc-alist (al)
38 : monnier 541 "Expand an alist AL where keys can be lists of keys into a normal one."
39 : monnier 334 (reduce (lambda (x al)
40 :     (let ((k (car x))
41 :     (v (cdr x)))
42 :     (if (consp k)
43 :     (append (mapcar (lambda (y) (cons y v)) k) al)
44 :     (cons x al))))
45 :     al
46 :     :initial-value nil
47 :     :from-end t))
48 :    
49 : monnier 332 ;;;
50 : monnier 535 ;;; defmap
51 : monnier 332 ;;;
52 :    
53 : monnier 319 (defun custom-create-map (m bs args)
54 : monnier 535 (let (inherit dense suppress)
55 : monnier 341 (while args
56 :     (let ((key (first args))
57 :     (val (second args)))
58 : monnier 319 (cond
59 : monnier 341 ((eq key :dense) (setq dense val))
60 :     ((eq key :inherit) (setq inherit val))
61 : monnier 535 ((eq key :group) )
62 :     ;;((eq key :suppress) (setq suppress val))
63 : monnier 341 (t (message "Uknown argument %s in defmap" key))))
64 :     (setq args (cddr args)))
65 :     (unless (keymapp m)
66 :     (setq bs (append m bs))
67 :     (setq m (if dense (make-keymap) (make-sparse-keymap))))
68 :     (dolist (b bs)
69 : monnier 535 (let ((keys (car b))
70 : monnier 341 (binding (cdr b)))
71 : monnier 535 (dolist (key (if (consp keys) keys (list keys)))
72 :     (cond
73 :     ((symbolp key)
74 :     (substitute-key-definition key binding m global-map))
75 :     ((null binding)
76 :     (unless (keymapp (lookup-key m key)) (define-key m key binding)))
77 :     ((let ((o (lookup-key m key)))
78 :     (or (null o) (numberp o) (eq o 'undefined)))
79 :     (define-key m key binding))))))
80 : monnier 341 (cond
81 :     ((keymapp inherit) (set-keymap-parent m inherit))
82 :     ((consp inherit) (set-keymap-parents m inherit)))
83 :     m))
84 : monnier 319
85 :     (defmacro defmap (m bs doc &rest args)
86 : monnier 332 `(defconst ,m
87 :     (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
88 :     ,doc))
89 : monnier 319
90 : monnier 332 ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
91 :    
92 :     (defun custom-create-syntax (css args)
93 :     (let ((st (make-syntax-table (cadr (memq :copy args)))))
94 :     (dolist (cs css)
95 :     (let ((char (car cs))
96 :     (syntax (cdr cs)))
97 :     (if (sequencep char)
98 :     (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
99 :     (modify-syntax-entry char syntax st))))
100 :     st))
101 :    
102 : monnier 319 (defmacro defsyntax (st css doc &rest args)
103 : monnier 332 `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
104 : monnier 319
105 : monnier 535 ;;;;
106 :     ;;;; Compatibility info
107 :     ;;;;
108 :    
109 :     (defvar sml-builtin-nested-comments-flag
110 :     (ignore-errors
111 :     (not (equal (let ((st (make-syntax-table)))
112 :     (modify-syntax-entry ?\* ". 23n" st) st)
113 :     (let ((st (make-syntax-table)))
114 :     (modify-syntax-entry ?\* ". 23" st) st))))
115 : monnier 541 "Non-nil means this Emacs understands the `n' in syntax entries.")
116 : monnier 535
117 : monnier 319 (provide 'sml-util)
118 : monnier 541
119 :     ;;; sml-util.el ends here

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