Mercurial > urweb

annotate src/elisp/urweb-compat.el @ 1355:ccf1d445b794

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Hopeful fix to stop Especialize infinite looping
author Adam Chlipala <adam@chlipala.net>
date Tue, 21 Dec 2010 13:57:12 -0500
parents 3a1e36b14105
children
rev   line source
adamc@350 1 ;;; urweb-compat.el --- Compatibility functions for Emacs variants for urweb-mode
adamc@350 2
adamc@350 3 ;; Based on sml-mode:
adamc@350 4 ;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org>
adamc@350 5 ;;
adamc@350 6 ;; Modified for urweb-mode:
adamc@350 7 ;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net>
adamc@350 8 ;;
adamc@350 9 ;; This program is free software; you can redistribute it and/or modify
adamc@350 10 ;; it under the terms of the GNU General Public License as published by
adamc@350 11 ;; the Free Software Foundation; either version 2 of the License, or
adamc@350 12 ;; (at your option) any later version.
adamc@350 13 ;;
adamc@350 14 ;; This program is distributed in the hope that it will be useful,
adamc@350 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
adamc@350 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
adamc@350 17 ;; GNU General Public License for more details.
adamc@350 18 ;;
adamc@350 19 ;; You should have received a copy of the GNU General Public License
adamc@350 20 ;; along with this program; if not, write to the Free Software
adamc@350 21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
adamc@350 22
adamc@350 23 ;;; Commentary:
adamc@350 24
adamc@350 25 ;;; Code:
adamc@350 26
adamc@350 27 (require 'cl)
adamc@350 28
adamc@350 29 (unless (fboundp 'set-keymap-parents)
adamc@350 30 (defun set-keymap-parents (m parents)
adamc@350 31 (if (keymapp parents) (setq parents (list parents)))
adamc@350 32 (set-keymap-parent
adamc@350 33 m
adamc@350 34 (if (cdr parents)
adamc@350 35 (reduce (lambda (m1 m2)
adamc@350 36 (let ((m (copy-keymap m1)))
adamc@350 37 (set-keymap-parent m m2) m))
adamc@350 38 parents
adamc@350 39 :from-end t)
adamc@350 40 (car parents)))))
adamc@350 41
adamc@350 42 ;; for XEmacs
adamc@350 43 (when (fboundp 'temp-directory)
adamc@350 44 (defvar temporary-file-directory (temp-directory)))
adamc@350 45
adamc@350 46 (unless (fboundp 'make-temp-file)
adamc@350 47 ;; Copied from Emacs-21's subr.el
adamc@350 48 (defun make-temp-file (prefix &optional dir-flag)
adamc@350 49 "Create a temporary file.
adamc@350 50 The returned file name (created by appending some random characters at the end
adamc@350 51 of PREFIX, and expanding against `temporary-file-directory' if necessary,
adamc@350 52 is guaranteed to point to a newly created empty file.
adamc@350 53 You can then use `write-region' to write new data into the file.
adamc@350 54
adamc@350 55 If DIR-FLAG is non-nil, create a new empty directory instead of a file."
adamc@350 56 (let (file)
adamc@350 57 (while (condition-case ()
adamc@350 58 (progn
adamc@350 59 (setq file
adamc@350 60 (make-temp-name
adamc@350 61 (expand-file-name prefix temporary-file-directory)))
adamc@350 62 (if dir-flag
adamc@350 63 (make-directory file)
adamc@350 64 (write-region "" nil file nil 'silent))
adamc@350 65 nil)
adamc@350 66 (file-already-exists t))
adamc@350 67 ;; the file was somehow created by someone else between
adamc@350 68 ;; `make-temp-name' and `write-region', let's try again.
adamc@350 69 nil)
adamc@350 70 file)))
adamc@350 71
adamc@350 72
adamc@350 73
adamc@350 74 (unless (fboundp 'regexp-opt)
adamc@350 75 (defun regexp-opt (strings &optional paren)
adamc@350 76 (let ((open (if paren "\\(" "")) (close (if paren "\\)" "")))
adamc@350 77 (concat open (mapconcat 'regexp-quote strings "\\|") close))))
adamc@350 78
adamc@350 79
adamc@350 80 ;;;;
adamc@350 81 ;;;; Custom
adamc@350 82 ;;;;
adamc@350 83
adamc@350 84 ;; doesn't exist in Emacs < 20.1
adamc@350 85 (unless (fboundp 'set-face-bold-p)
adamc@350 86 (defun set-face-bold-p (face v &optional f)
adamc@350 87 (when v (ignore-errors (make-face-bold face)))))
adamc@350 88 (unless (fboundp 'set-face-italic-p)
adamc@350 89 (defun set-face-italic-p (face v &optional f)
adamc@350 90 (when v (ignore-errors (make-face-italic face)))))
adamc@350 91
adamc@350 92 ;; doesn't exist in Emacs < 20.1
adamc@350 93 (ignore-errors (require 'custom))
adamc@350 94 (unless (fboundp 'defgroup)
adamc@350 95 (defmacro defgroup (&rest rest) ()))
adamc@350 96 (unless (fboundp 'defcustom)
adamc@350 97 (defmacro defcustom (sym val str &rest rest) `(defvar ,sym ,val ,str)))
adamc@350 98 (unless (fboundp 'defface)
adamc@350 99 (defmacro defface (sym val str &rest rest)
adamc@350 100 `(defvar ,sym (make-face ',sym) ,str)))
adamc@350 101
adamc@350 102 (defvar :group ':group)
adamc@350 103 (defvar :type ':type)
adamc@350 104 (defvar :copy ':copy)
adamc@350 105 (defvar :dense ':dense)
adamc@350 106 (defvar :inherit ':inherit)
adamc@350 107 (defvar :suppress ':suppress)
adamc@350 108
adamc@350 109 (provide 'urweb-compat)
adamc@350 110
adamc@350 111 ;;; urweb-compat.el ends here