sml-util.el

   1 ;;; sml-util.el --- Utility functions for sml-mode
   2
   3 ;; Copyright (C) 1999-2000, 2007, 2010  Stefan Monnier <monnier@iro.umontreal.ca>
   4 ;;
   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 3 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
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23
  24 (require 'cl)                           ;for `reduce'
  25
  26 (defun sml-preproc-alist (al)
  27   "Expand an alist AL where keys can be lists of keys into a normal one."
  28   (reduce (lambda (x al)
  29             (let ((k (car x))
  30                   (v (cdr x)))
  31               (if (consp k)
  32                   (append (mapcar (lambda (y) (cons y v)) k) al)
  33                 (cons x al))))
  34           al
  35           :initial-value nil
  36           :from-end t))
  37
  38 ;;;
  39 ;;; defmap
  40 ;;;
  41
  42 (defun custom-create-map (m bs args)
  43   (let (inherit dense suppress)
  44     (while args
  45       (let ((key (first args))
  46             (val (second args)))
  47         (cond
  48          ((eq key :dense) (setq dense val))
  49          ((eq key :inherit) (setq inherit val))
  50          ((eq key :group) )
  51          ;;((eq key :suppress) (setq suppress val))
  52          (t (message "Uknown argument %s in defmap" key))))
  53       (setq args (cddr args)))
  54     (unless (keymapp m)
  55       (setq bs (append m bs))
  56       (setq m (if dense (make-keymap) (make-sparse-keymap))))
  57     (dolist (b bs)
  58       (let ((keys (car b))
  59             (binding (cdr b)))
  60         (dolist (key (if (consp keys) keys (list keys)))
  61           (cond
  62            ((symbolp key)
  63             (substitute-key-definition key binding m global-map))
  64            ((null binding)
  65             (unless (keymapp (lookup-key m key)) (define-key m key binding)))
  66            ((let ((o (lookup-key m key)))
  67               (or (null o) (numberp o) (eq o 'undefined)))
  68             (define-key m key binding))))))
  69     (cond
  70      ((keymapp inherit) (set-keymap-parent m inherit))
  71      ((consp inherit) (set-keymap-parents m inherit)))
  72     m))
  73
  74 (defmacro defmap (m bs doc &rest args)
  75   `(defvar ,m
  76      (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
  77      ,doc))
  78
  79 ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80
  81 (defun custom-create-syntax (css args)
  82   (let ((st (make-syntax-table (cadr (memq :copy args)))))
  83     (dolist (cs css)
  84       (let ((char (car cs))
  85             (syntax (cdr cs)))
  86         (if (sequencep char)
  87             (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
  88           (modify-syntax-entry char syntax st))))
  89     st))
  90
  91 (defmacro defsyntax (st css doc &rest args)
  92   `(defvar ,st (custom-create-syntax ,css ,(cons 'list args)) ,doc))
  93
  94 ;;;;
  95 ;;;; Compatibility info
  96 ;;;;
  97
  98 (defvar sml-builtin-nested-comments-flag
  99   (ignore-errors
 100     (not (equal (let ((st (make-syntax-table)))
 101                   (modify-syntax-entry ?\* ". 23n" st) st)
 102                 (let ((st (make-syntax-table)))
 103                   (modify-syntax-entry ?\* ". 23" st) st))))
 104   "Non-nil means this Emacs understands the `n' in syntax entries.")
 105
 106 (provide 'sml-util)
 107
 108 ;;; sml-util.el ends here