cgit.sxemacs.org Git - packages/blob - xemacs-packages/sml-mode/sml-util.el

   1 ;;; sml-util.el --- Utility functions for sml-mode
   2
   3 ;; Copyright (C) 1999-2000  Stefan Monnier <monnier@cs.yale.edu>
   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 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
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23
  24 (require 'cl)                           ;for `reduce'
  25 (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 (defun sml-preproc-alist (al)
  38   "Expand an alist AL where keys can be lists of keys into a normal one."
  39   (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 ;;;
  50 ;;; defmap
  51 ;;;
  52
  53 (defun custom-create-map (m bs args)
  54   (let (inherit dense suppress)
  55     (while args
  56       (let ((key (first args))
  57             (val (second args)))
  58         (cond
  59          ((eq key :dense) (setq dense val))
  60          ((eq key :inherit) (setq inherit val))
  61          ((eq key :group) )
  62          ;;((eq key :suppress) (setq suppress val))
  63          (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       (let ((keys (car b))
  70             (binding (cdr b)))
  71         (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     (cond
  81      ((keymapp inherit) (set-keymap-parent m inherit))
  82      ((consp inherit) (set-keymap-parents m inherit)))
  83     m))
  84
  85 (defmacro defmap (m bs doc &rest args)
  86   `(defconst ,m
  87      (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
  88      ,doc))
  89
  90 ;; 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 (defmacro defsyntax (st css doc &rest args)
 103   `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) ,doc))
 104
 105 ;;;;
 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   "Non-nil means this Emacs understands the `n' in syntax entries.")
 116
 117 (provide 'sml-util)
 118
 119 ;;; sml-util.el ends here