Mercurial > hg > xemacs-beta

comparison lisp/ilisp/ilisp-utl.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children b82b59fe008d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; -*- Mode: Emacs-Lisp -*-
2
3 ;;; ilisp-utl.el --
4
5 ;;; This file is part of ILISP.
6 ;;; Version: 5.7
7 ;;;
8 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
9 ;;; 1993, 1994 Ivan Vasquez
10 ;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker
11 ;;;
12 ;;; Other authors' names for which this Copyright notice also holds
13 ;;; may appear later in this file.
14 ;;;
15 ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
16 ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
17 ;;; mailing list were bugs and improvements are discussed.
18 ;;;
19 ;;; ILISP is freely redistributable under the terms found in the file
20 ;;; COPYING.
21
22
23
24 ;;;
25 ;;; ILISP misc tools.
26 ;;;
27
28 (defun lisp-show-send (string)
29 "Show STRING in the *ilisp-send* buffer."
30 (save-excursion
31 (if (ilisp-buffer)
32 (set-buffer "*ilisp-send*")
33 (error "You must start an inferior LISP with run-ilisp."))
34 (erase-buffer)
35 (insert string)
36 string))
37
38
39 ;;;
40 (defun lisp-slashify (string)
41 "Put string in the *ilisp-send* buffer, put backslashes before
42 quotes and backslashes and return the resulting string."
43 (save-excursion
44 (lisp-show-send string)
45 (set-buffer "*ilisp-send*")
46 (goto-char (point-min))
47 (while (search-forward "\\" nil t)
48 (delete-char -1)
49 (insert "\\\\"))
50 (goto-char (point-min))
51 (while (search-forward "\"" nil t)
52 (backward-char)
53 (insert ?\\)
54 (forward-char))
55 (buffer-substring (point-min) (point-max))))
56
57
58 ;;;%%String
59 (defun lisp-prefix-p (s1 s2)
60 "Returns t if S1 is a prefix of S2 considering all non alphanumerics
61 as word delimiters."
62 (let ((len1 (length s1)))
63 (and (<= len1 (length s2))
64 (let ((start 0)
65 (start2 0)
66 end
67 (match t))
68 (while
69 (if (setq end (string-match "[^a-zA-Z0-9]" s1 start))
70 ;; Found delimiter
71 (if (string= (substring s1 start end)
72 (substring s2 start2 (+ start2 (- end start))))
73 ;; Words are the same
74 (progn (setq start (match-end 0))
75 (if (string-match
76 (regexp-quote (substring s1 end start))
77 s2 start2)
78 (setq start2 (match-end 0)) ;OK
79 (setq match nil))) ;Can't find delimiter
80 (setq match nil)) ;Words don't match
81 nil)) ;Ran out of delimiters in s1
82 (and match
83 (string= (substring s1 start len1)
84 (substring s2 start2 (+ start2 (- len1 start)))))))))
85
86
87 ;;;
88 (defun lisp-last-line (string)
89 "Return the last line of STRING with everything else."
90 (let* ((position 0))
91 (while (string-match "\\(\n+\\)[^\n]" string position)
92 (setq position (match-end 1)))
93 (cons (substring string position)
94 (substring string 0 position))))
95
96
97 ;;;%%File
98 ;;;
99 (defun lisp-file-extension (file extension)
100 "Return FILE with new EXTENSION."
101 (concat (substring file 0 (string-match ".[^.]*$" file))
102 "." extension))
103
104 (defun ilisp-directory (file &optional dirs)
105 "Return the directory of DIRS that FILE is found in. By default
106 load-path is used for the directories."
107 (let* ((dirs (or dirs (cons "" load-path)))
108 (dir (car dirs)))
109 (while (and dir (not (file-exists-p (expand-file-name file dir))))
110 (setq dirs (cdr dirs)
111 dir (car dirs)))
112 dir))
113
114
115 ;;; ilisp-update-status --
116 ;;;
117 ;;; Note: changed in order to propagate the status change in the
118 ;;; underlying process to the menu.
119
120 (defun ilisp-update-status (status)
121 "Update process STATUS of the whole Ilisp system.
122 It updates the STATUS of the current buffer and let all lisp mode
123 buffers know as well. Also, do some 'exterior' things like make sure
124 that the menubar is in a consistent state."
125 (setq ilisp-status (if lisp-show-status (format " :%s" status)))
126 (if (not (member +ilisp-emacs-version-id+ '(xemacs lucid-19 lucid-19-new)))
127 (ilisp-update-menu status))
128 (comint-update-status status))