1 | ;;; singular.el --- Emacs support for Computer Algebra System Singular |
---|
2 | |
---|
3 | ;; $Id: singular.el,v 1.30 1999-08-10 17:45:56 wichmann Exp $ |
---|
4 | |
---|
5 | ;;; Commentary: |
---|
6 | |
---|
7 | |
---|
8 | ;;; Code: |
---|
9 | |
---|
10 | ;;{{{ Style and coding conventions |
---|
11 | |
---|
12 | ;; Style and coding conventions: |
---|
13 | ;; |
---|
14 | ;; - "Singular" is written with an upper-case `S' in comments, doc |
---|
15 | ;; strings, and messages. As part of symbols, it is written with |
---|
16 | ;; a lower-case `s'. |
---|
17 | ;; - When referring to the Singular interactive mode, do it in that |
---|
18 | ;; wording. Use the notation `singular-interactive-mode' only when |
---|
19 | ;; really referring to the lisp object. |
---|
20 | ;; - use a `fill-column' of 75 for doc strings and comments |
---|
21 | ;; - mark incomplete doc strings or code with `NOT READY' optionally |
---|
22 | ;; followed by an explanation what exactly is missing |
---|
23 | ;; |
---|
24 | ;; - use foldings to structure the source code but try not to exceed a |
---|
25 | ;; maximum depth of two foldings |
---|
26 | ;; - use lowercase folding titles except for first word |
---|
27 | ;; - folding-marks are `;;{{{' and `;;}}}' resp., for sake of standard |
---|
28 | ;; conformity |
---|
29 | ;; - use the foldings to modularize code. That is, each folding should be, |
---|
30 | ;; as far as possible, self-content. Define a function `singular-*-init' |
---|
31 | ;; in the folding to do the initialization of the module contained in |
---|
32 | ;; that folding. Call that function from `singular-interactive-mode', |
---|
33 | ;; for example, instead of initializing the module directly from |
---|
34 | ;; `singular-interactive-mode'. Look at the code how it is done for the |
---|
35 | ;; simple section or for the folding stuff. |
---|
36 | ;; |
---|
37 | ;; - use `singular' as prefix for all global symbols |
---|
38 | ;; - use `singular-debug' as prefix for all global symbols concerning |
---|
39 | ;; debugging. |
---|
40 | ;; - use, whenever possible without names becoming too clumsy, some unique |
---|
41 | ;; prefix inside a folding |
---|
42 | ;; |
---|
43 | ;; - mark dependencies on Emacs flavor/version with a comment of the form |
---|
44 | ;; `;; Emacs[ <version> ]' resp. |
---|
45 | ;; `;; XEmacs[ <version> ][ <nasty comment> ]' |
---|
46 | ;; specified in that order, if possible |
---|
47 | ;; - use a `cond' statement to execute Emacs flavor/version-dependent code, |
---|
48 | ;; not `if'. This is to make such checks more extensible. |
---|
49 | ;; - try to define different functions for different flavors/version and |
---|
50 | ;; use `singular-fset' at library-loading time to set the function you |
---|
51 | ;; really need. If the function is named `singular-<basename>', the |
---|
52 | ;; flavor/version-dependent functions should be named |
---|
53 | ;; `singular-<flavor>[-<version>]-<basename>'. |
---|
54 | ;; |
---|
55 | ;; - use `singular-debug' for debugging output/actions |
---|
56 | ;; - to switch between buffer and process names, use the functions |
---|
57 | ;; `singular-process-name-to-buffer-name' and |
---|
58 | ;; `singular-buffer-name-to-process-name' |
---|
59 | ;; - call the function `singular-keep-region-active' as last statement in |
---|
60 | ;; an interactive function that should keep the region active (for |
---|
61 | ;; example, in functions that move the point). This is necessary to keep |
---|
62 | ;; XEmacs' zmacs regions active. |
---|
63 | ;; - to get the process of the current buffer, use `singular-process'. To |
---|
64 | ;; get the current process mark, use `singular-process-mark'. Both |
---|
65 | ;; functions check whether Singular is alive and throw an error if not, |
---|
66 | ;; so you do not have to care about that yourself. If you do not want an |
---|
67 | ;; error specify non-nil argument NO-ERROR. But use them anyway. |
---|
68 | ;; - we assume that the buffer is *not* read-only |
---|
69 | |
---|
70 | ;;}}} |
---|
71 | |
---|
72 | ;;{{{ Code common to both modes |
---|
73 | ;;{{{ Customizing |
---|
74 | (defgroup singular-faces nil |
---|
75 | "Faces in Singular mode and Singular interactive mode." |
---|
76 | :group 'faces |
---|
77 | :group 'singular-interactive) |
---|
78 | ;;}}} |
---|
79 | |
---|
80 | ;;{{{ Debugging stuff |
---|
81 | (defvar singular-debug nil |
---|
82 | "List of modes to debug or t to debug all modes. |
---|
83 | Currently, the following modes are supported: |
---|
84 | `interactive', |
---|
85 | `interactive-filter'.") |
---|
86 | |
---|
87 | (defun singular-debug-format (string) |
---|
88 | "Return STRING in a nicer format." |
---|
89 | (save-match-data |
---|
90 | (while (string-match "\n" string) |
---|
91 | (setq string (replace-match "^J" nil nil string))) |
---|
92 | |
---|
93 | (if (> (length string) 16) |
---|
94 | (concat "<" (substring string 0 7) ">...<" (substring string -8) ">") |
---|
95 | (concat "<" string ">")))) |
---|
96 | |
---|
97 | (defmacro singular-debug (mode form &optional else-form) |
---|
98 | "Major debugging hook for singular.el. |
---|
99 | Evaluates FORM if `singular-debug' equals t or if MODE is an element |
---|
100 | of `singular-debug', othwerwise ELSE-FORM." |
---|
101 | `(if (or (eq singular-debug t) |
---|
102 | (memq ,mode singular-debug)) |
---|
103 | ,form |
---|
104 | ,else-form)) |
---|
105 | ;;}}} |
---|
106 | |
---|
107 | ;;{{{ Determining version |
---|
108 | (defvar singular-emacs-flavor nil |
---|
109 | "A symbol describing the current Emacs. |
---|
110 | Currently, only Emacs \(`emacs') and XEmacs \(`xemacs') are supported.") |
---|
111 | |
---|
112 | (defvar singular-emacs-major-version nil |
---|
113 | "An integer describing the major version of the current emacs.") |
---|
114 | |
---|
115 | (defvar singular-emacs-minor-version nil |
---|
116 | "An integer describing the minor version of the current emacs.") |
---|
117 | |
---|
118 | (defun singular-fset (real-function emacs-function xemacs-function) |
---|
119 | "Set REAL-FUNCTION to one of the functions, in dependency on Emacs flavor and version. |
---|
120 | Sets REAL-FUNCTION to XEMACS-FUNCTION if `singular-emacs-flavor' is |
---|
121 | `xemacs', otherwise sets REAL-FUNCTION to EMACS-FUNCTION. |
---|
122 | |
---|
123 | This is not as common as it would be desirable. But it is sufficient so |
---|
124 | far." |
---|
125 | (cond |
---|
126 | ;; XEmacs |
---|
127 | ((eq singular-emacs-flavor 'xemacs) |
---|
128 | (fset real-function xemacs-function)) |
---|
129 | ;; Emacs |
---|
130 | (t |
---|
131 | (fset real-function emacs-function)))) |
---|
132 | |
---|
133 | (defun singular-set-version () |
---|
134 | "Determine flavor, major version, and minor version of current emacs. |
---|
135 | singular.el is guaranteed to run on Emacs 20.3 and XEmacs 20.3. |
---|
136 | It should run on newer version and on slightly older ones, too. |
---|
137 | |
---|
138 | This function is called exactly once when singular.el is loaded." |
---|
139 | ;; get major and minor versions first |
---|
140 | (if (and (boundp 'emacs-major-version) |
---|
141 | (boundp 'emacs-minor-version)) |
---|
142 | (setq singular-emacs-major-version emacs-major-version |
---|
143 | singular-emacs-minor-version emacs-minor-version) |
---|
144 | (with-output-to-temp-buffer "*singular warnings*" |
---|
145 | (princ |
---|
146 | "You seem to have quite an old Emacs or XEmacs version. Some of the |
---|
147 | features from singular.el will not work properly. Consider upgrading to a |
---|
148 | more recent version of Emacs or XEmacs. singular.el is guaranteed to run |
---|
149 | on Emacs 20.3 and XEmacs 20.3.")) |
---|
150 | ;; assume the oldest version we support |
---|
151 | (setq singular-emacs-major-version 20 |
---|
152 | singular-emacs-minor-version 3)) |
---|
153 | |
---|
154 | ;; get flavor |
---|
155 | (if (string-match "XEmacs\\|Lucid" emacs-version) |
---|
156 | (setq singular-emacs-flavor 'xemacs) |
---|
157 | (setq singular-emacs-flavor 'emacs))) |
---|
158 | |
---|
159 | (singular-set-version) |
---|
160 | ;;}}} |
---|
161 | |
---|
162 | ;;{{{ Syntax table |
---|
163 | (defvar singular-mode-syntax-table nil |
---|
164 | "Syntax table for `singular-interactive-mode' resp. `singular-mode'.") |
---|
165 | |
---|
166 | (if singular-mode-syntax-table |
---|
167 | () |
---|
168 | (setq singular-mode-syntax-table (make-syntax-table)) |
---|
169 | ;; stolen from cc-mode.el except for back-tics which are special to Singular |
---|
170 | (modify-syntax-entry ?_ "_" singular-mode-syntax-table) |
---|
171 | (modify-syntax-entry ?\\ "\\" singular-mode-syntax-table) |
---|
172 | (modify-syntax-entry ?+ "." singular-mode-syntax-table) |
---|
173 | (modify-syntax-entry ?- "." singular-mode-syntax-table) |
---|
174 | (modify-syntax-entry ?= "." singular-mode-syntax-table) |
---|
175 | (modify-syntax-entry ?% "." singular-mode-syntax-table) |
---|
176 | (modify-syntax-entry ?< "." singular-mode-syntax-table) |
---|
177 | (modify-syntax-entry ?> "." singular-mode-syntax-table) |
---|
178 | (modify-syntax-entry ?& "." singular-mode-syntax-table) |
---|
179 | (modify-syntax-entry ?| "." singular-mode-syntax-table) |
---|
180 | (modify-syntax-entry ?\' "\"" singular-mode-syntax-table) |
---|
181 | (modify-syntax-entry ?\` "\"" singular-mode-syntax-table) |
---|
182 | ;; block and line-oriented comments |
---|
183 | (cond |
---|
184 | ;; Emacs |
---|
185 | ((eq singular-emacs-flavor 'emacs) |
---|
186 | (modify-syntax-entry ?/ ". 124b" singular-mode-syntax-table) |
---|
187 | (modify-syntax-entry ?* ". 23" singular-mode-syntax-table)) |
---|
188 | ;; XEmacs |
---|
189 | (t |
---|
190 | (modify-syntax-entry ?/ ". 1456" singular-mode-syntax-table) |
---|
191 | (modify-syntax-entry ?* ". 23" singular-mode-syntax-table))) |
---|
192 | (modify-syntax-entry ?\n "> b" singular-mode-syntax-table) |
---|
193 | (modify-syntax-entry ?\^m "> b" singular-mode-syntax-table)) |
---|
194 | |
---|
195 | (defun singular-mode-syntax-table-init () |
---|
196 | "Initialize syntax table of current buffer. |
---|
197 | |
---|
198 | This function is called at mode initialization time." |
---|
199 | (set-syntax-table singular-mode-syntax-table)) |
---|
200 | ;;}}} |
---|
201 | |
---|
202 | ;;{{{ Miscellaneous |
---|
203 | (defsubst singular-keep-region-active () |
---|
204 | "Do whatever is necessary to keep the region active in XEmacs. |
---|
205 | Ignore byte-compiler warnings you might see. This is not needed for |
---|
206 | Emacs." |
---|
207 | ;; XEmacs. We do not use the standard way here to test for flavor |
---|
208 | ;; because it is presumably faster with that test on `boundp'. |
---|
209 | (and (boundp 'zmacs-region-stays) |
---|
210 | (setq zmacs-region-stays t))) |
---|
211 | ;;}}} |
---|
212 | ;;}}} |
---|
213 | |
---|
214 | ;;{{{ Singular interactive mode |
---|
215 | ;;{{{ Customizing |
---|
216 | |
---|
217 | ;; Note: |
---|
218 | ;; |
---|
219 | ;; Some notes on Customize: |
---|
220 | ;; |
---|
221 | ;; - The documentation states that for the `:initialize' option of |
---|
222 | ;; `defcustom' the default value is `custom-initialize-set'. However, in |
---|
223 | ;; the source code of Customize `custom-initialize-reset' is used. So |
---|
224 | ;; better always specify the `:initialize' option explicitly. |
---|
225 | ;; - Customize is bad at setting buffer-local variables or properties. |
---|
226 | ;; This is quite natural since Customize itself uses its own buffer. So |
---|
227 | ;; changing buffer-local variables and properties with Customize is |
---|
228 | ;; possible only at a "Singular-global" level. That is, for all buffers |
---|
229 | ;; currently having Singular interactive mode as major mode. The function |
---|
230 | ;; `singular-map-buffer' helps to do such customization. |
---|
231 | ;; |
---|
232 | ;; Some common customizing patterns: |
---|
233 | ;; |
---|
234 | ;; - How to customize buffer-local properties? |
---|
235 | ;; First, the `defcustom' itself must not set anything buffer-local since |
---|
236 | ;; at time of its definition (most likely) no Singular buffers will be |
---|
237 | ;; around. If there are Singular buffers we do not care about them. But |
---|
238 | ;; anyhow, at definition of the `defcustom' the global default has to be |
---|
239 | ;; set. Hence, the `:initialize' option should be set to |
---|
240 | ;; `custom-initialize-default'. |
---|
241 | ;; The buffer-local initialization has to be done at mode initialization |
---|
242 | ;; time. The global default value should then be used to set the local |
---|
243 | ;; properties. |
---|
244 | ;; At last, the function specified with the `:set' option should set the |
---|
245 | ;; local properties in all Singular buffers to the new, customized value. |
---|
246 | ;; Most likely, the function `singular-map-buffer' may be used for that. |
---|
247 | ;; In addition, the function should, of course, set the global value via |
---|
248 | ;; `set-default'. |
---|
249 | ;; For an example, see `singular-folding-line-move-ignore-folding'. |
---|
250 | ;; |
---|
251 | ;; - How to encapsulate other mode's global variables into Singular |
---|
252 | ;; interactive mode variables? |
---|
253 | ;; Set them always. That is, set them if the `defcustom' is evaluated |
---|
254 | ;; (use `custom-initialize-reset' as `:initial' function) and set them |
---|
255 | ;; when the Singular interactive mode variable is customized (by means |
---|
256 | ;; of an appropriate `:set' function). |
---|
257 | ;; For an example, see `singular-section-face-alist' (which does not |
---|
258 | ;; encapsulate another mode's variable, but Singular interactive mode's |
---|
259 | ;; own variable `singular-simple-sec-clear-type'). |
---|
260 | |
---|
261 | (defgroup singular-interactive nil |
---|
262 | "Running Singular with Emacs or XEmacs as front end." |
---|
263 | :group 'processes) |
---|
264 | |
---|
265 | (defgroup singular-sections-and-foldings nil |
---|
266 | "Sections and foldings in Singular interactive mode." |
---|
267 | :group 'singular-interactive) |
---|
268 | |
---|
269 | (defgroup singular-interactive-miscellaneous nil |
---|
270 | "Miscellaneous settings for Singular interactive mode." |
---|
271 | :group 'singular-interactive) |
---|
272 | |
---|
273 | (defgroup singular-demo-mode nil |
---|
274 | "Settings concerning Singular demo mode." |
---|
275 | :group 'singular-interactive) |
---|
276 | |
---|
277 | (defun singular-map-buffer (func &rest args) |
---|
278 | "Apply FUNC to ARGS in all existing Singular buffers. |
---|
279 | That is, in all buffers having Singular interactive major mode. The |
---|
280 | function is executed in the context of the buffer. This is a must-have for |
---|
281 | the customizing stuff to change buffer-local properties." |
---|
282 | (save-excursion |
---|
283 | (mapcar (function |
---|
284 | (lambda (buffer) |
---|
285 | (set-buffer buffer) |
---|
286 | (if (eq major-mode 'singular-interactive-mode) |
---|
287 | (apply func args)))) |
---|
288 | (buffer-list)))) |
---|
289 | ;;}}} |
---|
290 | |
---|
291 | ;;{{{ Comint |
---|
292 | |
---|
293 | ;; Note: |
---|
294 | ;; |
---|
295 | ;; We require Comint, but we really do not use it too much. One may argue |
---|
296 | ;; that this is bad since Comint is a standardized way to communicate with |
---|
297 | ;; external processes. One may argue further that many experienced Emacs |
---|
298 | ;; users are forced now to re-do their Comint customization for Singular |
---|
299 | ;; interactive mode. However, we believe that the intersection between |
---|
300 | ;; experienced Emacs users and users of Singular interactive mode is almost |
---|
301 | ;; empty. |
---|
302 | ;; |
---|
303 | ;; In fact, we used Comint really much in the beginning of this project. |
---|
304 | ;; Later during development it turned at that using Comint's input and |
---|
305 | ;; output processing is to inflexible and not appropriate for Singular |
---|
306 | ;; interactive mode with its input and output sections. So we begun to |
---|
307 | ;; rewrite large portions of Comint to adapt it to our needs. At some |
---|
308 | ;; point it came clear that it would be best to throw out Comint |
---|
309 | ;; alltogether, would not have been there some auxilliary functions which |
---|
310 | ;; are really useful but annoying to rewrite. These are, for example, the |
---|
311 | ;; command line history functions or the completion stuff offered by |
---|
312 | ;; Comint. |
---|
313 | ;; |
---|
314 | ;; Our policy with regard to these remainders of Comint is: Use the |
---|
315 | ;; functions to bind them to keys, but do not use them internally. |
---|
316 | ;; Encapsulate Comint customization into Singular interactive mode |
---|
317 | ;; customization. In particular, do not take care about Comint settings |
---|
318 | ;; which already may be present, overwrite them. Hide Comint from the |
---|
319 | ;; user. |
---|
320 | ;; |
---|
321 | ;; Here is how exactly we use Comint: |
---|
322 | ;; |
---|
323 | ;; - All variables necessary to use Comint's input ring are properly |
---|
324 | ;; initialized. One may find this in the `History' folding. |
---|
325 | ;; - `comint-prompt-regexp' is initialized since it is used in some |
---|
326 | ;; of the functions regarding input ring handling. Furthermore, its |
---|
327 | ;; initialization enables us to use functions as `comint-bol', etc. |
---|
328 | ;; Initialization is done in the `Skipping and stripping prompts ...' |
---|
329 | ;; folding. |
---|
330 | ;; - We call `comint-mode' as first step in `singular-interactive-mode'. |
---|
331 | ;; Most of the work done there is to initialize the local variables as |
---|
332 | ;; necessary. Besides that, the function does nothing that interferes |
---|
333 | ;; with Singular interactive mode. To be consequent we set |
---|
334 | ;; `comint-mode-hook' temporarily to nil when calling `comint-mode'. |
---|
335 | ;; - In `singular-exec', we use `comint-exec-1' to fire up the process. |
---|
336 | ;; Furthermore, we set `comint-ptyp' there as it is used in the signal |
---|
337 | ;; sending commands of Comint. All that `comint-exec-1' does is that it |
---|
338 | ;; sets up the process environment (it adds or modifies the setting of |
---|
339 | ;; the 'TERM' variable), sets the execution directory, and does some |
---|
340 | ;; magic with the process coding stuff. |
---|
341 | ;; - One more time the most important point: we do *not* use Comint's |
---|
342 | ;; output and input processing. In particular, we do not run any of |
---|
343 | ;; Comint's hooks on input or output. Anyway, we do better, don't we? |
---|
344 | |
---|
345 | (require 'comint) |
---|
346 | ;;}}} |
---|
347 | |
---|
348 | ;;{{{ Font-locking |
---|
349 | (defvar singular-font-lock-error-face 'singular-font-lock-error-face |
---|
350 | "Face name to use for Singular errors.") |
---|
351 | |
---|
352 | (defvar singular-font-lock-warning-face 'singular-font-lock-warning-face |
---|
353 | "Face name to use for Singular warnings.") |
---|
354 | |
---|
355 | (defvar singular-font-lock-prompt-face 'singular-font-lock-prompt-face |
---|
356 | "Face name to use for Singular prompts.") |
---|
357 | |
---|
358 | (defface singular-font-lock-error-face |
---|
359 | '((((class color)) (:foreground "Red" :bold t)) |
---|
360 | (t (:inverse-video t :bold t))) |
---|
361 | "*Font Lock mode face used to highlight Singular errors." |
---|
362 | :group 'singular-faces) |
---|
363 | |
---|
364 | (defface singular-font-lock-warning-face |
---|
365 | '((((class color)) (:foreground "OrangeRed" :bold nil)) |
---|
366 | (t (:inverse-video t :bold t))) |
---|
367 | "*Font Lock mode face used to highlight Singular warnings." |
---|
368 | :group 'singular-faces) |
---|
369 | |
---|
370 | (defface singular-font-lock-prompt-face |
---|
371 | '((((class color) (background light)) (:foreground "Blue" :bold t)) |
---|
372 | (((class color) (background dark)) (:foreground "LightSkyBlue" :bold t)) |
---|
373 | (t (:inverse-video t :bold t))) |
---|
374 | "*Font Lock mode face used to highlight Singular prompts." |
---|
375 | :group 'singular-faces) |
---|
376 | |
---|
377 | (defconst singular-font-lock-singular-types nil |
---|
378 | "List of Singular types.") |
---|
379 | |
---|
380 | (eval-when-compile |
---|
381 | (setq singular-font-lock-singular-types |
---|
382 | '("def" "ideal" "int" "intmat" "intvec" "link" "list" "map" "matrix" |
---|
383 | "module" "number" "poly" "proc" "qring" "resolution" "ring" "string" |
---|
384 | "vector"))) |
---|
385 | |
---|
386 | (defconst singular-interactive-font-lock-keywords-1 |
---|
387 | '( |
---|
388 | ("^\\([>.]\\) " 1 singular-font-lock-prompt-face t) |
---|
389 | ("^ [\\?].*" 0 singular-font-lock-error-face t) |
---|
390 | ("^// \\*\\*.*" 0 singular-font-lock-warning-face t) |
---|
391 | ) |
---|
392 | "Subdued level highlighting for Singular interactive mode") |
---|
393 | |
---|
394 | (defconst singular-interactive-font-lock-keywords-2 |
---|
395 | (append |
---|
396 | singular-interactive-font-lock-keywords-1 |
---|
397 | (eval-when-compile |
---|
398 | (list |
---|
399 | (cons |
---|
400 | (concat "\\<" (regexp-opt singular-font-lock-singular-types t) "\\>") |
---|
401 | 'font-lock-type-face)))) |
---|
402 | "Medium level highlighting for Singular interactive mode") |
---|
403 | |
---|
404 | (defconst singular-interactive-font-lock-keywords-3 |
---|
405 | (append |
---|
406 | singular-interactive-font-lock-keywords-2 |
---|
407 | '( |
---|
408 | ("^ [\\?].*`\\(\\sw\\sw+\\)`" 1 font-lock-reference-name-face t) |
---|
409 | )) |
---|
410 | "Gaudy level highlighting for Singular interactive mode.") |
---|
411 | |
---|
412 | (defconst singular-interactive-font-lock-keywords singular-interactive-font-lock-keywords-1 |
---|
413 | "Default highlighting for Singular interactive mode.") |
---|
414 | |
---|
415 | (defconst singular-interactive-font-lock-defaults |
---|
416 | '((singular-interactive-font-lock-keywords |
---|
417 | singular-interactive-font-lock-keywords-1 |
---|
418 | singular-interactive-font-lock-keywords-2 |
---|
419 | singular-interactive-font-lock-keywords-3) |
---|
420 | ;; KEYWORDS-ONLY (do not fontify strings & comments if non-nil) |
---|
421 | nil |
---|
422 | ;; CASE-FOLD (ignore case if non-nil) |
---|
423 | nil |
---|
424 | ;; SYNTAX-ALIST (add this to Font Lock's syntax table) |
---|
425 | ((?_ . "w")) |
---|
426 | ;; SYNTAX-BEGIN |
---|
427 | singular-section-goto-beginning) |
---|
428 | "Default expressions to highlight in Singular interactive mode.") |
---|
429 | |
---|
430 | (defun singular-interactive-font-lock-init () |
---|
431 | "Initialize Font Lock mode for Singular interactive mode. |
---|
432 | |
---|
433 | For XEmacs, this function is called exactly once when singular.el is |
---|
434 | loaded. |
---|
435 | For Emacs, this function is called at mode initialization time." |
---|
436 | (cond |
---|
437 | ;; Emacs |
---|
438 | ((eq singular-emacs-flavor 'emacs) |
---|
439 | (singular-debug 'interactive (message "Setting up Font Lock mode for Emacs")) |
---|
440 | (set (make-local-variable 'font-lock-defaults) |
---|
441 | singular-interactive-font-lock-defaults)) |
---|
442 | ;; XEmacs |
---|
443 | ((eq singular-emacs-flavor 'xemacs) |
---|
444 | (singular-debug 'interactive (message "Setting up Font Lock mode for XEmacs")) |
---|
445 | (put 'singular-interactive-mode |
---|
446 | 'font-lock-defaults singular-interactive-font-lock-defaults)))) |
---|
447 | |
---|
448 | ;; XEmacs Font Lock mode initialization |
---|
449 | (cond |
---|
450 | ;; XEmacs |
---|
451 | ((eq singular-emacs-flavor 'xemacs) |
---|
452 | (singular-interactive-font-lock-init))) |
---|
453 | ;;}}} |
---|
454 | |
---|
455 | ;;{{{ Key map |
---|
456 | (defvar singular-interactive-mode-map nil |
---|
457 | "Key map to use in Singular interactive mode.") |
---|
458 | |
---|
459 | (if singular-interactive-mode-map |
---|
460 | () |
---|
461 | ;; create empty keymap first |
---|
462 | (cond |
---|
463 | ;; Emacs |
---|
464 | ((eq singular-emacs-flavor 'emacs) |
---|
465 | (setq singular-interactive-mode-map (make-sparse-keymap))) |
---|
466 | ;; XEmacs |
---|
467 | (t |
---|
468 | (setq singular-interactive-mode-map (make-keymap)) |
---|
469 | (set-keymap-name singular-interactive-mode-map |
---|
470 | 'singular-interactive-mode-map))) |
---|
471 | |
---|
472 | ;; define keys |
---|
473 | (define-key singular-interactive-mode-map [?\C-m] 'singular-send-or-copy-input) |
---|
474 | (define-key singular-interactive-mode-map [?\M-r] 'comint-previous-matching-input) |
---|
475 | (define-key singular-interactive-mode-map [?\M-s] 'comint-next-matching-input) |
---|
476 | |
---|
477 | ;; C-c prefix |
---|
478 | (define-key singular-interactive-mode-map [?\C-c ?\C-f] 'singular-folding-toggle-fold-at-point-or-all) |
---|
479 | (define-key singular-interactive-mode-map [?\C-c ?\C-o] 'singular-folding-toggle-fold-latest-output) |
---|
480 | (define-key singular-interactive-mode-map [?\C-c ?\C-l] 'singular-recenter)) |
---|
481 | |
---|
482 | (defcustom singular-history-keys '(meta) |
---|
483 | "Keys to use for history access. |
---|
484 | Should be a list describing which keys or key combinations to use for |
---|
485 | history access in Singular interactive mode. Valid entries are `control', |
---|
486 | `cursor', and `meta'. |
---|
487 | |
---|
488 | For more information one should refer to the documentation of |
---|
489 | `singular-history-keys'. |
---|
490 | |
---|
491 | Changing this variable has an immediate effect only if one uses |
---|
492 | \\[customize] to do so." |
---|
493 | :type '(set (const :tag "Cursor keys" cursor) |
---|
494 | (const :tag "C-p, C-n" control) |
---|
495 | (const :tag "M-p, M-n" meta)) |
---|
496 | :initialize 'custom-initialize-default |
---|
497 | :set (function |
---|
498 | (lambda (var value) |
---|
499 | (singular-history-cursor-keys-set value singular-cursor-keys) |
---|
500 | (set-default var value))) |
---|
501 | :group 'singular-interactive-miscellaneous) |
---|
502 | |
---|
503 | (defcustom singular-cursor-keys '(control cursor) |
---|
504 | "Keys to use for cursor movement. |
---|
505 | Should be a list describing which keys or key combinations to use for |
---|
506 | cursor movement in Singular interactive mode. Valid entries are `control', |
---|
507 | `cursor', and `meta'. |
---|
508 | |
---|
509 | An experienced Emacs user would prefer setting `singular-cursor-keys' to |
---|
510 | `(control cursor)' and `singular-history-keys' to `(meta)'. This means |
---|
511 | that C-p, C-n, and the cursor keys move the cursor, whereas M-p and M-n |
---|
512 | scroll through the history of Singular commands. |
---|
513 | |
---|
514 | On the other hand, an user used to running Singular in a, say, xterm, would |
---|
515 | prefer the other way round: Setting the variable `singular-history-keys' to |
---|
516 | `(control cursor)' and `singular-cursor-keys' to `(meta)'. |
---|
517 | |
---|
518 | Keys which are not mentioned in both lists are not modified from their |
---|
519 | standard settings. Naturally, the lists `singular-cursor-keys' and |
---|
520 | `singular-history-keys' should be disjunct. |
---|
521 | |
---|
522 | Changing this variable has an immediate effect only if one uses |
---|
523 | \\[customize] to do so." |
---|
524 | :type '(set (const :tag "Cursor keys" cursor) |
---|
525 | (const :tag "C-p, C-n" control) |
---|
526 | (const :tag "M-p, M-n" meta)) |
---|
527 | :initialize 'custom-initialize-default |
---|
528 | :set (function |
---|
529 | (lambda (var value) |
---|
530 | (singular-history-cursor-keys-set singular-history-keys value) |
---|
531 | (set-default var value))) |
---|
532 | :group 'singular-interactive-miscellaneous) |
---|
533 | |
---|
534 | (defun singular-history-cursor-key-set (key function-spec) |
---|
535 | "Set keys corresponding to KEY and according to FUNCTION-SPEC. |
---|
536 | FUNCTION-SPEC should be a cons cell of the format (PREV-FUNC . NEXT-FUNC)." |
---|
537 | (cond |
---|
538 | ((eq key 'control) |
---|
539 | (define-key singular-interactive-mode-map [?\C-p] (car function-spec)) |
---|
540 | (define-key singular-interactive-mode-map [?\C-n] (cdr function-spec))) |
---|
541 | ((eq key 'meta) |
---|
542 | (define-key singular-interactive-mode-map [?\M-p] (car function-spec)) |
---|
543 | (define-key singular-interactive-mode-map [?\M-n] (cdr function-spec))) |
---|
544 | ((eq key 'cursor) |
---|
545 | (define-key singular-interactive-mode-map [up] (car function-spec)) |
---|
546 | (define-key singular-interactive-mode-map [down] (cdr function-spec))))) |
---|
547 | |
---|
548 | (defun singular-history-cursor-keys-set (history-keys cursor-keys) |
---|
549 | "Set the keys according to HISTORY-KEYS and CURSOR-KEYS. |
---|
550 | Checks whether HISTORY-KEYS and CURSOR-KEYS are disjunct. Throws an error |
---|
551 | if not." |
---|
552 | ;; do the check first |
---|
553 | (if (memq nil (mapcar (function (lambda (elt) (not (memq elt history-keys)))) |
---|
554 | cursor-keys)) |
---|
555 | (error "History keys and cursor keys are not disjunct (see `singular-cursor-keys')")) |
---|
556 | |
---|
557 | ;; remove old bindings first |
---|
558 | (singular-history-cursor-key-set 'cursor '(nil . nil)) |
---|
559 | (singular-history-cursor-key-set 'control '(nil . nil)) |
---|
560 | (singular-history-cursor-key-set 'meta '(nil . nil)) |
---|
561 | |
---|
562 | ;; set new bindings |
---|
563 | (mapcar (function |
---|
564 | (lambda (key) |
---|
565 | (singular-history-cursor-key-set key '(comint-previous-input . comint-next-input)))) |
---|
566 | history-keys) |
---|
567 | (mapcar (function |
---|
568 | (lambda (key) |
---|
569 | (singular-history-cursor-key-set key '(previous-line . next-line)))) |
---|
570 | cursor-keys)) |
---|
571 | |
---|
572 | ;; static initialization. Deferred to this point since at the time where |
---|
573 | ;; the defcustoms are defined not all necessary functions and variables are |
---|
574 | ;; available. |
---|
575 | (singular-history-cursor-keys-set singular-history-keys singular-cursor-keys) |
---|
576 | |
---|
577 | (defun singular-interactive-mode-map-init () |
---|
578 | "Initialize key map for Singular interactive mode. |
---|
579 | |
---|
580 | This function is called at mode initialization time." |
---|
581 | (use-local-map singular-interactive-mode-map)) |
---|
582 | ;;}}} |
---|
583 | |
---|
584 | ;;{{{ Menus and logos |
---|
585 | (defvar singular-interactive-mode-menu-1 nil |
---|
586 | "NOT READY [docu]") |
---|
587 | |
---|
588 | (defvar singular-interactive-mode-menu-2 nil |
---|
589 | "NOT READY [docu]") |
---|
590 | |
---|
591 | (defvar singular-start-menu-definition |
---|
592 | '("Singular" |
---|
593 | ["start default" singular t] |
---|
594 | ["start..." singular-other t] |
---|
595 | ["exit" singular-exit-singular t]) |
---|
596 | "NOT READY [docu]") |
---|
597 | |
---|
598 | (if singular-interactive-mode-menu-1 |
---|
599 | () |
---|
600 | (cond |
---|
601 | ;; XEmacs |
---|
602 | ((eq singular-emacs-flavor 'xemacs) |
---|
603 | (easy-menu-define |
---|
604 | singular-interactive-mode-menu-1 |
---|
605 | singular-interactive-mode-map "" |
---|
606 | singular-start-menu-definition)))) |
---|
607 | |
---|
608 | (if singular-interactive-mode-menu-2 |
---|
609 | () |
---|
610 | (cond |
---|
611 | ;; XEmacs |
---|
612 | ((eq singular-emacs-flavor 'xemacs) |
---|
613 | (easy-menu-define |
---|
614 | singular-interactive-mode-menu-2 |
---|
615 | singular-interactive-mode-map "" |
---|
616 | '("Commands" |
---|
617 | ["load file..." singular-load-file t] |
---|
618 | ("load library" |
---|
619 | ["all.lib" (singular-load-library "all.lib" t) t] |
---|
620 | ["classify.lib" (singular-load-library "classify.lib" t) t] |
---|
621 | ["deform.lib" (singular-load-library "deform.lib" t) t] |
---|
622 | ["elim.lib" (singular-load-library "elim.lib" t) t] |
---|
623 | ["finvar.lib" (singular-load-library "finvar.lib" t) t] |
---|
624 | ["general.lib" (singular-load-library "general.lib" t) t] |
---|
625 | ["graphics.lib" (singular-load-library "graphics.lib" t) t] |
---|
626 | ["hnoether.lib" (singular-load-library "hnoether.lib" t) t] |
---|
627 | ["homolog.lib" (singular-load-library "homolog.lib" t) t] |
---|
628 | ["inout.lib" (singular-load-library "inout.lib" t) t] |
---|
629 | ["invar.lib" (singular-load-library "invar.lib" t) t] |
---|
630 | ["latex.lib" (singular-load-library "latex.lib" t) t] |
---|
631 | ["matrix.lib" (singular-load-library "matrix.lib" t) t] |
---|
632 | ["normal.lib" (singular-load-library "normal.lib" t) t] |
---|
633 | ["poly.lib" (singular-load-library "poly.lib" t) t] |
---|
634 | ["presolve.lib" (singular-load-library "presolve.lib" t) t] |
---|
635 | ["primdec.lib" (singular-load-library "primdec.lib" t) t] |
---|
636 | ["primitiv.lib" (singular-load-library "primitiv.lib" t) t] |
---|
637 | ["random.lib" (singular-load-library "random.lib" t) t] |
---|
638 | ["ring.lib" (singular-load-library "ring.lib" t) t] |
---|
639 | ["sing.lib" (singular-load-library "sing.lib" t) t] |
---|
640 | ["standard.lib" (singular-load-library "standard.lib" t) t] |
---|
641 | "---" |
---|
642 | ["other..." singular-load-library t]) |
---|
643 | "---" |
---|
644 | ["load demo" singular-demo-load (not singular-demo-mode)] |
---|
645 | ["exit demo" singular-demo-exit singular-demo-mode] |
---|
646 | "---" |
---|
647 | ["truncate lines" singular-toggle-truncate-lines |
---|
648 | :style toggle :selected truncate-lines] |
---|
649 | "---" |
---|
650 | ["fold last output" singular-fold-last-output t] |
---|
651 | ["fold all output" singular-fold-all-output t] |
---|
652 | ["fold at point" singular-fold-at-point t] |
---|
653 | "---" |
---|
654 | ["unfold last output" singular-unfold-last-output t] |
---|
655 | ["unfold all output" singular-unfold-all-output t] |
---|
656 | ["unfold at point" singular-unfold-at-point t] |
---|
657 | ))))) |
---|
658 | |
---|
659 | ;; NOT READY |
---|
660 | ;; This is just a temporary hack for XEmacs demo. |
---|
661 | (defvar singular-install-in-main-menu nil |
---|
662 | "NOT READY [docu]") |
---|
663 | |
---|
664 | (if singular-install-in-main-menu |
---|
665 | (cond |
---|
666 | ;; XEmacs |
---|
667 | ((eq singular-emacs-flavor 'xemacs) |
---|
668 | (add-submenu nil |
---|
669 | singular-start-menu-definition)))) |
---|
670 | |
---|
671 | ;; remove existing singular-start-menu from menu (XEmacs) |
---|
672 | ;, NOT READY |
---|
673 | ;; This is mayby just temporary |
---|
674 | ; (cond |
---|
675 | ; ;; XEmacs |
---|
676 | ; ((eq singular-emacs-flavor 'xemacs) |
---|
677 | ; (delete-menu-item '("Singular")))) |
---|
678 | |
---|
679 | ;; NOT READY: SINGULAR-LOGO |
---|
680 | ; (cond |
---|
681 | ; ((eq singular-emacs-flavor 'xemacs) |
---|
682 | ; (set-extent-begin-glyph (make-extent (point-min) (point-min)) |
---|
683 | ; singular-logo) |
---|
684 | ; (insert "\n"))) |
---|
685 | |
---|
686 | ;; NOT READY: SINGULAR-LOGO |
---|
687 | ;(cond |
---|
688 | ; ((eq singular-emacs-flavor 'xemacs) |
---|
689 | ; (defvar singular-logo (make-glyph)) |
---|
690 | ; (set-glyph-image singular-logo |
---|
691 | ; (concat "~/" "singlogo.xpm") |
---|
692 | ; 'global 'x))) |
---|
693 | |
---|
694 | (defun singular-interactive-mode-menu-init () |
---|
695 | "Initialize menus for Singular interactive mode. |
---|
696 | |
---|
697 | This function is called at mode initialization time." |
---|
698 | (cond |
---|
699 | ;; XEmacs |
---|
700 | ((eq singular-emacs-flavor 'xemacs) |
---|
701 | (easy-menu-add singular-interactive-mode-menu-1) |
---|
702 | (easy-menu-add singular-interactive-mode-menu-2)))) |
---|
703 | ;;}}} |
---|
704 | |
---|
705 | ;;{{{ Skipping and stripping prompts and newlines and other things |
---|
706 | |
---|
707 | ;; Note: |
---|
708 | ;; |
---|
709 | ;; All of these functions modify the match data! |
---|
710 | |
---|
711 | (defun singular-strip-white-space (string &optional trailing leading) |
---|
712 | "Strip off trailing or leading white-space from STRING. |
---|
713 | Strips off trailing white-space if optional argument TRAILING is |
---|
714 | non-nil. |
---|
715 | Strips off leading white-space if optional argument LEADING is |
---|
716 | non-nil." |
---|
717 | (let ((beg 0) |
---|
718 | (end (length string))) |
---|
719 | (and leading |
---|
720 | (string-match "\\`\\s-*" string) |
---|
721 | (setq beg (match-end 0))) |
---|
722 | (and trailing |
---|
723 | (string-match "\\s-*\\'" string beg) |
---|
724 | (setq end (match-beginning 0))) |
---|
725 | (substring string beg end))) |
---|
726 | |
---|
727 | (defconst singular-extended-prompt-regexp "\\([?>.] \\)" |
---|
728 | "Matches one Singular prompt. |
---|
729 | Should not be anchored neither to start nor to end!") |
---|
730 | |
---|
731 | (defconst singular-strip-leading-prompt-regexp |
---|
732 | (concat "\\`" singular-extended-prompt-regexp "+") |
---|
733 | "Matches Singular prompt anchored to string start.") |
---|
734 | |
---|
735 | (defun singular-strip-leading-prompt (string) |
---|
736 | "Strip leading prompts from STRING. |
---|
737 | May or may not return STRING or a modified copy of it." |
---|
738 | (if (string-match singular-strip-leading-prompt-regexp string) |
---|
739 | (substring string (match-end 0)) |
---|
740 | string)) |
---|
741 | |
---|
742 | (defconst singular-remove-prompt-regexp |
---|
743 | (concat "^" singular-extended-prompt-regexp |
---|
744 | "*" singular-extended-prompt-regexp) |
---|
745 | "Matches a non-empty sequence of prompts at start of a line.") |
---|
746 | |
---|
747 | (defun singular-remove-prompt (beg end) |
---|
748 | "Remove all superfluous prompts from region between BEG and END. |
---|
749 | Removes all but the last prompt of a sequence if that sequence ends at |
---|
750 | END. |
---|
751 | The region between BEG and END should be accessible. |
---|
752 | Leaves point after the last prompt found." |
---|
753 | (let ((end (copy-marker end)) |
---|
754 | prompt-end) |
---|
755 | (goto-char beg) |
---|
756 | (while (and (setq prompt-end |
---|
757 | (re-search-forward singular-remove-prompt-regexp end t)) |
---|
758 | (not (= end prompt-end))) |
---|
759 | (delete-region (match-beginning 0) prompt-end)) |
---|
760 | |
---|
761 | ;; check for trailing prompt |
---|
762 | (if prompt-end |
---|
763 | (delete-region (match-beginning 0) (match-beginning 2))) |
---|
764 | (set-marker end nil))) |
---|
765 | |
---|
766 | (defconst singular-skip-prompt-forward-regexp |
---|
767 | (concat singular-extended-prompt-regexp "*") |
---|
768 | "Matches an arbitary sequence of Singular prompts.") |
---|
769 | |
---|
770 | (defun singular-prompt-skip-forward () |
---|
771 | "Skip forward over prompts." |
---|
772 | (looking-at singular-skip-prompt-forward-regexp) |
---|
773 | (goto-char (match-end 0))) |
---|
774 | |
---|
775 | (defun singular-skip-prompt-backward () |
---|
776 | "Skip backward over prompts." |
---|
777 | (while (re-search-backward singular-extended-prompt-regexp (- (point) 2) t))) |
---|
778 | |
---|
779 | (defun singular-remove-prompt-filter (beg end simple-sec-start) |
---|
780 | "Strip prompts from last simple section." |
---|
781 | (if simple-sec-start (singular-remove-prompt simple-sec-start end))) |
---|
782 | |
---|
783 | (defvar singular-prompt-regexp "^> " |
---|
784 | "Regexp to match prompt patterns in Singular. |
---|
785 | Should not match the continuation prompt \(`.'), only the regular |
---|
786 | prompt \(`>'). |
---|
787 | |
---|
788 | This variable is used to initialize `comint-prompt-regexp' when |
---|
789 | Singular interactive mode starts up.") |
---|
790 | ;;}}} |
---|
791 | |
---|
792 | ;;{{{ Miscellaneous |
---|
793 | |
---|
794 | ;; Note: |
---|
795 | ;; |
---|
796 | ;; We assume a one-to-one correspondence between Singular buffers and |
---|
797 | ;; Singular processes. We always have (equal buffer-name (concat "*" |
---|
798 | ;; process-name "*")). |
---|
799 | |
---|
800 | (defsubst singular-buffer-name-to-process-name (buffer-name) |
---|
801 | "Create the process name for BUFFER-NAME. |
---|
802 | The process name is the buffer name with surrounding `*' stripped off." |
---|
803 | (substring buffer-name 1 -1)) |
---|
804 | |
---|
805 | (defsubst singular-process-name-to-buffer-name (process-name) |
---|
806 | "Create the buffer name for PROCESS-NAME. |
---|
807 | The buffer name is the process name with surrounding `*'." |
---|
808 | (concat "*" process-name "*")) |
---|
809 | |
---|
810 | (defsubst singular-run-hook-with-arg-and-value (hook value) |
---|
811 | "Call functions on HOOK. |
---|
812 | Provides argument VALUE to the functions. If a function returns a non-nil |
---|
813 | value it replaces VALUE as new argument to the remaining functions. |
---|
814 | Returns final VALUE." |
---|
815 | (while hook |
---|
816 | (setq value (or (funcall (car hook) value) value) |
---|
817 | hook (cdr hook))) |
---|
818 | value) |
---|
819 | |
---|
820 | (defsubst singular-process (&optional no-error) |
---|
821 | "Return process of current buffer. |
---|
822 | If no process is active this function silently returns nil if optional |
---|
823 | argument NO-ERROR is non-nil, otherwise it throws an error." |
---|
824 | (cond ((get-buffer-process (current-buffer))) |
---|
825 | (no-error nil) |
---|
826 | (t (error "No Singular running in this buffer")))) |
---|
827 | |
---|
828 | (defsubst singular-process-mark (&optional no-error) |
---|
829 | "Return process mark of current buffer. |
---|
830 | If no process is active this function silently returns nil if optional |
---|
831 | argument NO-ERROR is non-nil, otherwise it throws an error." |
---|
832 | (let ((process (singular-process no-error))) |
---|
833 | (and process |
---|
834 | (process-mark process)))) |
---|
835 | |
---|
836 | (defun singular-time-stamp-difference (new-time-stamp old-time-stamp) |
---|
837 | "Return the number of seconds between NEW-TIME-STAMP and OLD-TIME-STAMP. |
---|
838 | Both NEW-TIME-STAMP and OLD-TIME-STAMP should be in the format |
---|
839 | that is returned, for example, by `current-time'. |
---|
840 | Does not return a difference larger than 2^17 seconds." |
---|
841 | (let ((high-difference (min 1 (- (car new-time-stamp) (car old-time-stamp)))) |
---|
842 | (low-difference (- (cadr new-time-stamp) (cadr old-time-stamp)))) |
---|
843 | (+ (* high-difference 131072) low-difference))) |
---|
844 | ;;}}} |
---|
845 | |
---|
846 | ;;{{{ Miscellaneous interactive |
---|
847 | (defun singular-recenter (&optional arg) |
---|
848 | "Center point in window and redisplay frame. With ARG, put point on line ARG. |
---|
849 | The desired position of point is always relative to the current window. |
---|
850 | Just C-u as prefix means put point in the center of the window. |
---|
851 | If ARG is omitted or nil, erases the entire frame and then redraws with |
---|
852 | point in the center of the current window. |
---|
853 | Scrolls window to the left margin and moves point to beginning of line." |
---|
854 | (interactive "P") |
---|
855 | (singular-reposition-point-and-window) |
---|
856 | (recenter arg)) |
---|
857 | |
---|
858 | (defun singular-reposition-point-and-window () |
---|
859 | "Scroll window to the left margin and move point to beginning of line." |
---|
860 | (interactive) |
---|
861 | (set-window-hscroll (selected-window) 0) |
---|
862 | (move-to-column 0) |
---|
863 | ;; be careful where to place point |
---|
864 | (singular-prompt-skip-forward)) |
---|
865 | |
---|
866 | (defun singular-toggle-truncate-lines () |
---|
867 | "Toggle `truncate-lines'. |
---|
868 | A non-nil value of `truncate-lines' means do not display continuation |
---|
869 | lines\; give each line of text one screen line. |
---|
870 | Repositions window and point after toggling `truncate-lines'." |
---|
871 | (interactive) |
---|
872 | (setq truncate-lines (not truncate-lines)) |
---|
873 | ;; reposition so that user does not get confused |
---|
874 | (singular-reposition-point-and-window)) |
---|
875 | |
---|
876 | ;; this is not a buffer-local variable even if at first glance it seems |
---|
877 | ;; that it should be one. But if one changes buffer the contents of this |
---|
878 | ;; variable becomes irrelevant since the last command is no longer a |
---|
879 | ;; horizontal scroll command. The same is true for the initial value, so |
---|
880 | ;; we set it to nil. |
---|
881 | (defvar singular-scroll-previous-amount nil |
---|
882 | "Amount of previous horizontal scroll command.") |
---|
883 | |
---|
884 | (defun singular-scroll-right (&optional scroll-amount) |
---|
885 | "Scroll selected window SCROLL-AMOUNT columns right. |
---|
886 | SCROLL-AMOUNT defaults to amount of previous horizontal scroll command. If |
---|
887 | the command immediately preceding this command has not been a horizontal |
---|
888 | scroll command SCROLL-AMOUNT defaults to window width minus 2. |
---|
889 | Moves point to leftmost visible column." |
---|
890 | (interactive "P") |
---|
891 | |
---|
892 | ;; get amount to scroll |
---|
893 | (setq singular-scroll-previous-amount |
---|
894 | (cond (scroll-amount (prefix-numeric-value scroll-amount)) |
---|
895 | ((eq last-command 'singular-scroll-horizontal) |
---|
896 | singular-scroll-previous-amount) |
---|
897 | (t (- (frame-width) 2))) |
---|
898 | this-command 'singular-scroll-horizontal) |
---|
899 | |
---|
900 | ;; scroll |
---|
901 | (scroll-right singular-scroll-previous-amount) |
---|
902 | (move-to-column (window-hscroll)) |
---|
903 | ;; be careful where to place point. But what if `(current-column)' |
---|
904 | ;; equals, say, one? Well, we simply do not care about that case. |
---|
905 | ;; Should not happen to often. |
---|
906 | (if (eq (current-column) 0) |
---|
907 | (singular-prompt-skip-forward))) |
---|
908 | |
---|
909 | (defun singular-scroll-left (&optional scroll-amount) |
---|
910 | "Scroll selected window SCROLL-AMOUNT columns left. |
---|
911 | SCROLL-AMOUNT defaults to amount of previous horizontal scroll command. If |
---|
912 | the command immediately preceding this command has not been a horizontal |
---|
913 | scroll command SCROLL-AMOUNT defaults to window width minus 2. |
---|
914 | Moves point to leftmost visible column." |
---|
915 | (interactive "P") |
---|
916 | |
---|
917 | ;; get amount to scroll |
---|
918 | (setq singular-scroll-previous-amount |
---|
919 | (cond (scroll-amount (prefix-numeric-value scroll-amount)) |
---|
920 | ((eq last-command 'singular-scroll-horizontal) |
---|
921 | singular-scroll-previous-amount) |
---|
922 | (t (- (frame-width) 2))) |
---|
923 | this-command 'singular-scroll-horizontal) |
---|
924 | |
---|
925 | ;; scroll |
---|
926 | (scroll-left singular-scroll-previous-amount) |
---|
927 | (move-to-column (window-hscroll)) |
---|
928 | ;; be careful where to place point. But what if `(current-column)' |
---|
929 | ;; equals, say, one? Well, we simply do not care about that case. |
---|
930 | ;; Should not happen to often. |
---|
931 | (if (eq (current-column) 0) |
---|
932 | (singular-prompt-skip-forward))) |
---|
933 | |
---|
934 | (defun singular-load-file (file &optional noexpand) |
---|
935 | "Read a file into Singular (via '< \"FILE\";'). |
---|
936 | If optional argument NOEXPAND is non-nil, FILE is left as it is entered by |
---|
937 | the user, otherwise it is expanded using `expand-file-name'." |
---|
938 | (interactive "fLoad file: ") |
---|
939 | (let* ((filename (if noexpand file (expand-file-name file))) |
---|
940 | (string (concat "< \"" filename "\";")) |
---|
941 | (process (singular-process))) |
---|
942 | (singular-input-filter process string) |
---|
943 | (singular-send-string process string))) |
---|
944 | |
---|
945 | (defun singular-load-library (file &optional noexpand) |
---|
946 | "Read a Singular library (via 'LIB \"FILE\";'). |
---|
947 | If optional argument NOEXPAND is non-nil, FILE is left as it is entered by |
---|
948 | the user, otherwise it is expanded using `expand-file-name'." |
---|
949 | (interactive "fLoad Library: ") |
---|
950 | (let* ((filename (if noexpand file (expand-file-name file))) |
---|
951 | (string (concat "LIB \"" filename "\";")) |
---|
952 | (process (singular-process))) |
---|
953 | (singular-input-filter process string) |
---|
954 | (singular-send-string process string))) |
---|
955 | |
---|
956 | (defun singular-exit-singular () |
---|
957 | "Exit Singular and kill Singular buffer. |
---|
958 | Sends string \"quit;\" to Singular process." |
---|
959 | (interactive) |
---|
960 | (let ((string "quit;") |
---|
961 | (process (singular-process))) |
---|
962 | (singular-input-filter process string) |
---|
963 | (singular-send-string process string)) |
---|
964 | (kill-buffer (current-buffer))) |
---|
965 | ;;}}} |
---|
966 | |
---|
967 | ;;{{{ History |
---|
968 | (defcustom singular-history-ignoredups t |
---|
969 | "If non-nil, do not add input matching the last on the input history." |
---|
970 | :type 'boolean |
---|
971 | :initialize 'custom-initialize-default |
---|
972 | :group 'singular-interactive-miscellaneous) |
---|
973 | |
---|
974 | ;; this variable is used to set Comint's `comint-input-ring-size' |
---|
975 | (defcustom singular-history-size 64 |
---|
976 | "Size of the input history. |
---|
977 | |
---|
978 | Changing this variable has no immediate effect even if one uses |
---|
979 | \\[customize] to do so. The new value will be used only in new Singular |
---|
980 | interactive mode buffers." |
---|
981 | :type 'integer |
---|
982 | :initialize 'custom-initialize-default |
---|
983 | :group 'singular-interactive-miscellaneous) |
---|
984 | |
---|
985 | (defcustom singular-history-filter-regexp "\\`\\(..?\\|\\s *\\)\\'" |
---|
986 | "Regular expression to filter strings *not* to insert in the input history. |
---|
987 | By default, input consisting of less than three characters and input |
---|
988 | consisting of white-space only is not inserted into the input history." |
---|
989 | :type 'regexp |
---|
990 | :initialize 'custom-initialize-default |
---|
991 | :group 'singular-interactive-miscellaneous) |
---|
992 | |
---|
993 | (defcustom singular-history-explicit-file-name nil |
---|
994 | "If non-nil, use this as file name to load and save the input history. |
---|
995 | If this variable equals nil, the `SINGULARHIST' environment variable is |
---|
996 | used to determine the file name. |
---|
997 | One should note that the input history is saved to file only on regular |
---|
998 | termination of Singular; that is, if one leaves Singular using the commands |
---|
999 | `quit\;' or `exit\;'." |
---|
1000 | :type '(choice (const nil) file) |
---|
1001 | :initialize 'custom-initialize-default |
---|
1002 | :group 'singular-interactive-miscellaneous) |
---|
1003 | |
---|
1004 | (defun singular-history-read () |
---|
1005 | "Read the input history from file. |
---|
1006 | If `singular-history-explicit-file-name' is non-nil, uses that as file |
---|
1007 | name, otherwise tries environment variable `SINGULARHIST'. |
---|
1008 | This function is called from `singular-exec' every time a new Singular |
---|
1009 | process is started." |
---|
1010 | (singular-debug 'interactive (message "Reading input ring")) |
---|
1011 | (let ((comint-input-ring-file-name (or singular-history-explicit-file-name |
---|
1012 | (getenv "SINGULARHIST")))) |
---|
1013 | ;; `comint-read-input-ring' does nothing if |
---|
1014 | ;; `comint-input-ring-file-name' equals nil |
---|
1015 | (comint-read-input-ring t))) |
---|
1016 | |
---|
1017 | (defun singular-history-write () |
---|
1018 | "Write back the input history to file. |
---|
1019 | If `singular-history-explicit-file-name' is non-nil, uses that as file |
---|
1020 | name, otherwise tries environment variable `SINGULARHIST'. |
---|
1021 | This function is called from `singular-exit-sentinel' every time a Singular |
---|
1022 | process terminates regularly." |
---|
1023 | (singular-debug 'interactive (message "Writing input ring back")) |
---|
1024 | (let ((comint-input-ring-file-name (or singular-history-explicit-file-name |
---|
1025 | (getenv "SINGULARHIST")))) |
---|
1026 | ;; `comint-write-input-ring' does nothing if |
---|
1027 | ;; `comint-input-ring-file-name' equals nil |
---|
1028 | (comint-write-input-ring))) |
---|
1029 | |
---|
1030 | (defun singular-history-insert (input) |
---|
1031 | "Insert string INPUT into the input history if necessary." |
---|
1032 | (if (and (not (string-match singular-history-filter-regexp input)) |
---|
1033 | (or singular-demo-insert-into-history |
---|
1034 | (not singular-demo-mode)) |
---|
1035 | (or (not singular-history-ignoredups) |
---|
1036 | (not (ring-p comint-input-ring)) |
---|
1037 | (ring-empty-p comint-input-ring) |
---|
1038 | (not (string-equal (ring-ref comint-input-ring 0) input)))) |
---|
1039 | (ring-insert comint-input-ring input)) |
---|
1040 | (setq comint-input-ring-index nil)) |
---|
1041 | |
---|
1042 | (defun singular-history-init () |
---|
1043 | "Initialize variables concerning the input history. |
---|
1044 | |
---|
1045 | This function is called at mode initialization time." |
---|
1046 | (setq comint-input-ring-size singular-history-size)) |
---|
1047 | ;;}}} |
---|
1048 | |
---|
1049 | ;;{{{ Simple section API for both Emacs and XEmacs |
---|
1050 | |
---|
1051 | ;; Note: |
---|
1052 | ;; |
---|
1053 | ;; Sections and simple sections are used to mark Singular's input and |
---|
1054 | ;; output for further access. Here are some general notes on simple |
---|
1055 | ;; sections. Sections are explained in the respective folding. |
---|
1056 | ;; |
---|
1057 | ;; In general, simple sections are more or less Emacs' overlays or XEmacs |
---|
1058 | ;; extents, resp. But they are more than simply an interface to overlays |
---|
1059 | ;; or extents. |
---|
1060 | ;; |
---|
1061 | ;; - Simple sections are non-empty portions of text. They are interpreted |
---|
1062 | ;; as left-closed, right-opened intervals, i.e., the start point of a |
---|
1063 | ;; simple sections belongs to it whereas the end point does not. |
---|
1064 | ;; - Simple sections start and end at line borders only. |
---|
1065 | ;; - Simple sections do not overlap. Thus, any point in the buffer may be |
---|
1066 | ;; covered by at most one simple section. |
---|
1067 | ;; - Besides from their start and their end, simple sections have some type |
---|
1068 | ;; associated. |
---|
1069 | ;; - Simple sections are realized using overlays (extents for XEmacs) |
---|
1070 | ;; which define the start and, end, and type (via properties) of the |
---|
1071 | ;; simple section. Actually, as a lisp object a simple section is |
---|
1072 | ;; nothing else but the underlying overlay. |
---|
1073 | ;; - There may be so-called clear simple sections. Clear simple sections |
---|
1074 | ;; have not an underlying overlay. Instead, they start at the end of the |
---|
1075 | ;; preceding non-clear simple section, end at the beginning of the next |
---|
1076 | ;; non-clear simple section, and have the type defined by |
---|
1077 | ;; `singular-simple-sec-clear-type'. Clear simple sections are |
---|
1078 | ;; represented by nil. |
---|
1079 | ;; - Buffer narrowing does not restrict the extent of completely or |
---|
1080 | ;; partially inaccessible simple sections. But one should note that |
---|
1081 | ;; some of the functions assume that there is no narrowing in |
---|
1082 | ;; effect. |
---|
1083 | ;; - After creation, simple sections are not modified any further. |
---|
1084 | ;; - There is one nasty little corner case: what if a non-clear simple |
---|
1085 | ;; section spans up to end of buffer? By definition, eob is not included |
---|
1086 | ;; in that section since they are right-opened intervals. Most of the |
---|
1087 | ;; functions react as if there is an imagenary empty clear simple section |
---|
1088 | ;; at eob. |
---|
1089 | ;; - Even though by now there are only two types of different simple |
---|
1090 | ;; sections there may be an arbitrary number of them. Furthermore, |
---|
1091 | ;; simple sections of different types may appear in arbitrary order. |
---|
1092 | ;; |
---|
1093 | ;; - In `singular-interactive-mode', the whole buffer is covered with |
---|
1094 | ;; simple sections from the very beginning of the file up to the |
---|
1095 | ;; beginning of the line containing the last input or output. The |
---|
1096 | ;; remaining text up to `(point-max)' may be interpreted as covered by |
---|
1097 | ;; one clear simple section. Thus, it is most reasonable to define |
---|
1098 | ;; `input' to be the type of clear simple sections. |
---|
1099 | |
---|
1100 | (defvar singular-simple-sec-clear-type 'input |
---|
1101 | "Type of clear simple sections. |
---|
1102 | If nil no clear simple sections are used. |
---|
1103 | |
---|
1104 | One should not set this variable directly. Rather, one should customize |
---|
1105 | `singular-section-face-alist'.") |
---|
1106 | |
---|
1107 | (defvar singular-simple-sec-last-end nil |
---|
1108 | "Marker at the end of the last simple section. |
---|
1109 | Should be initialized by `singular-simple-sec-init' before any calls to |
---|
1110 | `singular-simple-sec-create' are done. Instead of accessing this variable |
---|
1111 | directly one should use the macro `singular-simple-sec-last-end-position'. |
---|
1112 | |
---|
1113 | This variable is buffer-local.") |
---|
1114 | |
---|
1115 | (defun singular-simple-sec-init (pos) |
---|
1116 | "Initialize variables belonging to simple section management. |
---|
1117 | Creates the buffer-local marker `singular-simple-sec-last-end' and |
---|
1118 | initializes it to POS. POS should be at beginning of a line. |
---|
1119 | |
---|
1120 | This function is called every time a new Singular session is started." |
---|
1121 | (make-local-variable 'singular-simple-sec-last-end) |
---|
1122 | (if (not (markerp singular-simple-sec-last-end)) |
---|
1123 | (setq singular-simple-sec-last-end (make-marker))) |
---|
1124 | (set-marker singular-simple-sec-last-end pos)) |
---|
1125 | |
---|
1126 | (defmacro singular-simple-sec-last-end-position () |
---|
1127 | "Return the marker position of `singular-simple-sec-last-end'. |
---|
1128 | This macro exists more or less for purposes of information hiding only." |
---|
1129 | '(marker-position singular-simple-sec-last-end)) |
---|
1130 | |
---|
1131 | (defsubst singular-simple-sec-lookup-face (type) |
---|
1132 | "Return the face to use for simple sections of type TYPE. |
---|
1133 | This accesses the `singular-section-type-alist'. It does not harm if nil |
---|
1134 | is associated with TYPE in that alist: In this case, this function will |
---|
1135 | never be called for that TYPE." |
---|
1136 | (cdr (assq type singular-section-face-alist))) |
---|
1137 | |
---|
1138 | ;; Note: |
---|
1139 | ;; |
---|
1140 | ;; The rest of the folding is either marked as |
---|
1141 | ;; Emacs |
---|
1142 | ;; or |
---|
1143 | ;; XEmacs |
---|
1144 | |
---|
1145 | (singular-fset 'singular-simple-sec-create |
---|
1146 | 'singular-emacs-simple-sec-create |
---|
1147 | 'singular-xemacs-simple-sec-create) |
---|
1148 | |
---|
1149 | (singular-fset 'singular-simple-sec-at |
---|
1150 | 'singular-emacs-simple-sec-at |
---|
1151 | 'singular-xemacs-simple-sec-at) |
---|
1152 | |
---|
1153 | (singular-fset 'singular-simple-sec-start |
---|
1154 | 'singular-emacs-simple-sec-start |
---|
1155 | 'singular-xemacs-simple-sec-start) |
---|
1156 | |
---|
1157 | (singular-fset 'singular-simple-sec-end |
---|
1158 | 'singular-emacs-simple-sec-end |
---|
1159 | 'singular-xemacs-simple-sec-end) |
---|
1160 | |
---|
1161 | (singular-fset 'singular-simple-sec-type |
---|
1162 | 'singular-emacs-simple-sec-type |
---|
1163 | 'singular-xemacs-simple-sec-type) |
---|
1164 | |
---|
1165 | (singular-fset 'singular-simple-sec-before |
---|
1166 | 'singular-emacs-simple-sec-before |
---|
1167 | 'singular-xemacs-simple-sec-before) |
---|
1168 | |
---|
1169 | (singular-fset 'singular-simple-sec-start-at |
---|
1170 | 'singular-emacs-simple-sec-start-at |
---|
1171 | 'singular-xemacs-simple-sec-start-at) |
---|
1172 | |
---|
1173 | (singular-fset 'singular-simple-sec-end-at |
---|
1174 | 'singular-emacs-simple-sec-end-at |
---|
1175 | 'singular-xemacs-simple-sec-end-at) |
---|
1176 | |
---|
1177 | (singular-fset 'singular-simple-sec-in |
---|
1178 | 'singular-emacs-simple-sec-in |
---|
1179 | 'singular-xemacs-simple-sec-in) |
---|
1180 | ;;}}} |
---|
1181 | |
---|
1182 | ;;{{{ Simple section API for Emacs |
---|
1183 | (defsubst singular-emacs-simple-sec-start (simple-sec) |
---|
1184 | "Return start of non-clear simple section SIMPLE-SEC. |
---|
1185 | Narrowing has no effect on this function." |
---|
1186 | (overlay-start simple-sec)) |
---|
1187 | |
---|
1188 | (defsubst singular-emacs-simple-sec-end (simple-sec) |
---|
1189 | "Return end of non-clear simple section SIMPLE-SEC. |
---|
1190 | Narrowing has no effect on this function." |
---|
1191 | (overlay-end simple-sec)) |
---|
1192 | |
---|
1193 | (defsubst singular-emacs-simple-sec-type (simple-sec) |
---|
1194 | "Return type of SIMPLE-SEC. |
---|
1195 | Returns nil if SIMPLE-SEC happens to be an overlay but not a simple |
---|
1196 | section. |
---|
1197 | Narrowing has no effect on this function." |
---|
1198 | (if simple-sec |
---|
1199 | (overlay-get simple-sec 'singular-type) |
---|
1200 | singular-simple-sec-clear-type)) |
---|
1201 | |
---|
1202 | (defsubst singular-emacs-simple-sec-before (pos) |
---|
1203 | "Return simple section before buffer position POS. |
---|
1204 | This is the same as `singular-simple-sec-at' except if POS falls on a |
---|
1205 | section border. In this case `singular-simple-section-before' returns the |
---|
1206 | previous simple section instead of the current one. If POS falls on |
---|
1207 | beginning of buffer, the simple section at beginning of buffer is returned. |
---|
1208 | Narrowing has no effect on this function." |
---|
1209 | (singular-emacs-simple-sec-at (max 1 (1- pos)))) |
---|
1210 | |
---|
1211 | (defun singular-emacs-simple-sec-create (type end) |
---|
1212 | "Create a new simple section of type TYPE. |
---|
1213 | Creates the section from end of previous simple section up to the first |
---|
1214 | beginning of line before END. That position should be larger than or equal |
---|
1215 | to `singular-simple-sec-last-end'. Updates `singular-simple-sec-last-end'. |
---|
1216 | Returns the new simple section or `empty' if no simple section has been |
---|
1217 | created. |
---|
1218 | Assumes that no narrowing is in effect." |
---|
1219 | (let ((last-end (singular-simple-sec-last-end-position)) |
---|
1220 | ;; `simple-sec' is the new simple section or `empty' |
---|
1221 | simple-sec) |
---|
1222 | |
---|
1223 | ;; get beginning of line before END. At this point we need that there |
---|
1224 | ;; are no restrictions. |
---|
1225 | (setq end (let ((old-point (point))) |
---|
1226 | (goto-char end) (beginning-of-line) |
---|
1227 | (prog1 (point) (goto-char old-point)))) |
---|
1228 | |
---|
1229 | (cond |
---|
1230 | ;; do not create empty sections |
---|
1231 | ((eq end last-end) |
---|
1232 | 'empty) |
---|
1233 | ;; non-clear simple sections |
---|
1234 | ((not (eq type singular-simple-sec-clear-type)) |
---|
1235 | ;; if type has not changed we only have to extend the previous simple |
---|
1236 | ;; section. If `last-end' happens to be 1 (meaning that we are |
---|
1237 | ;; creating the first non-clear simple section in the buffer), then |
---|
1238 | ;; `singular-simple-sec-before' returns nil, |
---|
1239 | ;; `singular-simple-sec-type' returns the type of clear simple |
---|
1240 | ;; sections that definitely does not equal TYPE, and a new simple |
---|
1241 | ;; section is created as necessary. |
---|
1242 | (setq simple-sec (singular-emacs-simple-sec-before last-end)) |
---|
1243 | (if (eq type (singular-emacs-simple-sec-type simple-sec)) |
---|
1244 | ;; move existing overlay |
---|
1245 | (setq simple-sec (move-overlay simple-sec (overlay-start simple-sec) end)) |
---|
1246 | ;; create new overlay |
---|
1247 | (setq simple-sec (make-overlay last-end end)) |
---|
1248 | ;; set type property |
---|
1249 | (overlay-put simple-sec 'singular-type type) |
---|
1250 | ;; set face |
---|
1251 | (overlay-put simple-sec 'face (singular-simple-sec-lookup-face type)) |
---|
1252 | ;; evaporate empty sections |
---|
1253 | (overlay-put simple-sec 'evaporate t)) |
---|
1254 | ;; update `singular-simple-sec-last-end' and return new simple |
---|
1255 | ;; section |
---|
1256 | (set-marker singular-simple-sec-last-end end) |
---|
1257 | simple-sec) |
---|
1258 | ;; clear simple sections |
---|
1259 | (t |
---|
1260 | ;; update `singular-simple-sec-last-end' and return nil |
---|
1261 | (set-marker singular-simple-sec-last-end end) |
---|
1262 | nil)))) |
---|
1263 | |
---|
1264 | (defun singular-emacs-simple-sec-start-at (pos) |
---|
1265 | "Return start of clear simple section at position POS. |
---|
1266 | Assumes the existence of an imagenary empty clear simple section if POS is |
---|
1267 | at end of buffer and there is non-clear simple section immediately ending |
---|
1268 | at POS. |
---|
1269 | Assumes that no narrowing is in effect (since `previous-overlay-change' |
---|
1270 | imlicitly does so)." |
---|
1271 | ;; yes, this `(1+ pos)' is OK at eob for |
---|
1272 | ;; `singular-emacs-simple-sec-before' as well as |
---|
1273 | ;; `previous-overlay-change' |
---|
1274 | (let ((previous-overlay-change-pos (1+ pos))) |
---|
1275 | ;; this `while' loop at last will run into the end of the next |
---|
1276 | ;; non-clear simple section or stop at bob. Since POS may be right at |
---|
1277 | ;; the end of a previous non-clear location, we have to search at least |
---|
1278 | ;; one time from POS+1 backwards. |
---|
1279 | (while (not (or (singular-emacs-simple-sec-before previous-overlay-change-pos) |
---|
1280 | (eq previous-overlay-change-pos 1))) |
---|
1281 | (setq previous-overlay-change-pos |
---|
1282 | (previous-overlay-change previous-overlay-change-pos))) |
---|
1283 | previous-overlay-change-pos)) |
---|
1284 | |
---|
1285 | (defun singular-emacs-simple-sec-end-at (pos) |
---|
1286 | "Return end of clear simple section at position POS. |
---|
1287 | Assumes the existence of an imagenary empty clear simple section if POS is |
---|
1288 | at end of buffer and there is non-clear simple section immediately ending |
---|
1289 | at POS. |
---|
1290 | Assumes that no narrowing is in effect (since `next-overlay-change' |
---|
1291 | imlicitly does so)." |
---|
1292 | (let ((next-overlay-change-pos (next-overlay-change pos))) |
---|
1293 | ;; this `while' loop at last will run into the beginning of the next |
---|
1294 | ;; non-clear simple section or stop at eob. Since POS may not be at |
---|
1295 | ;; the beginning of a non-clear simple section we may start searching |
---|
1296 | ;; immediately. |
---|
1297 | (while (not (or (singular-emacs-simple-sec-at next-overlay-change-pos) |
---|
1298 | (eq next-overlay-change-pos (point-max)))) |
---|
1299 | (setq next-overlay-change-pos |
---|
1300 | (next-overlay-change next-overlay-change-pos))) |
---|
1301 | next-overlay-change-pos)) |
---|
1302 | |
---|
1303 | (defun singular-emacs-simple-sec-at (pos) |
---|
1304 | "Return simple section at buffer position POS. |
---|
1305 | Assumes the existence of an imagenary empty clear simple section if POS is |
---|
1306 | at end of buffer and there is non-clear simple section immediately ending |
---|
1307 | at POS. |
---|
1308 | Narrowing has no effect on this function." |
---|
1309 | ;; at eob, `overlays-at' always returns nil so everything is OK for this |
---|
1310 | ;; case, too |
---|
1311 | (let ((overlays (overlays-at pos)) simple-sec) |
---|
1312 | ;; be careful, there may be other overlays! |
---|
1313 | (while (and overlays (not simple-sec)) |
---|
1314 | (if (singular-emacs-simple-sec-type (car overlays)) |
---|
1315 | (setq simple-sec (car overlays))) |
---|
1316 | (setq overlays (cdr overlays))) |
---|
1317 | simple-sec)) |
---|
1318 | |
---|
1319 | (defun singular-emacs-simple-sec-in (beg end) |
---|
1320 | "Return a list of all simple sections intersecting with the region from BEG to END. |
---|
1321 | A simple section intersects the region if the section and the region have |
---|
1322 | at least one character in common. The sections are returned with |
---|
1323 | startpoints in increasing order and clear simple sections (that is, nil's) |
---|
1324 | inserted as necessary. BEG is assumed to be less than or equal to END. |
---|
1325 | The imagenary empty clear simple section at end of buffer is never included |
---|
1326 | in the result. |
---|
1327 | Narrowing has no effect on this function." |
---|
1328 | (let (overlays overlay-cursor) |
---|
1329 | (if (= beg end) |
---|
1330 | ;; `overlays-in' seems not be correct with respect to this case |
---|
1331 | nil |
---|
1332 | ;; go to END since chances are good that the overlays come in correct |
---|
1333 | ;; order, then |
---|
1334 | (setq overlays (let ((old-point (point))) |
---|
1335 | (goto-char end) |
---|
1336 | (prog1 (overlays-in beg end) |
---|
1337 | (goto-char old-point))) |
---|
1338 | |
---|
1339 | ;; now, turn overlays that are not simple sections into nils |
---|
1340 | overlays (mapcar (function |
---|
1341 | (lambda (overlay) |
---|
1342 | (and (singular-emacs-simple-sec-type overlay) |
---|
1343 | overlay))) |
---|
1344 | overlays) |
---|
1345 | ;; then, remove nils from list |
---|
1346 | overlays (delq nil overlays) |
---|
1347 | ;; now, we have to sort the list since documentation of `overlays-in' |
---|
1348 | ;; does not state anything about the order the overlays are returned in |
---|
1349 | overlays |
---|
1350 | (sort overlays |
---|
1351 | (function |
---|
1352 | (lambda (a b) |
---|
1353 | (< (overlay-start a) (overlay-start b)))))) |
---|
1354 | |
---|
1355 | ;; at last, we have the list of non-clear simple sections. Now, go and |
---|
1356 | ;; insert clear simple sections as necessary. |
---|
1357 | (if (null overlays) |
---|
1358 | ;; if there are no non-clear simple sections at all there can be |
---|
1359 | ;; only one large clear simple section |
---|
1360 | '(nil) |
---|
1361 | ;; we care about inside clear simple section first |
---|
1362 | (setq overlay-cursor overlays) |
---|
1363 | (while (cdr overlay-cursor) |
---|
1364 | (if (eq (overlay-end (car overlay-cursor)) |
---|
1365 | (overlay-start (cadr overlay-cursor))) |
---|
1366 | (setq overlay-cursor (cdr overlay-cursor)) |
---|
1367 | ;; insert nil |
---|
1368 | (setcdr overlay-cursor |
---|
1369 | (cons nil (cdr overlay-cursor))) |
---|
1370 | (setq overlay-cursor (cddr overlay-cursor)))) |
---|
1371 | ;; now, check BEG and END for clear simple sections |
---|
1372 | (if (> (overlay-start (car overlays)) beg) |
---|
1373 | (setq overlays (cons nil overlays))) |
---|
1374 | ;; `overlay-cursor' still points to the end |
---|
1375 | (if (< (overlay-end (car overlay-cursor)) end) |
---|
1376 | (setcdr overlay-cursor (cons nil nil))) |
---|
1377 | overlays)))) |
---|
1378 | ;;}}} |
---|
1379 | |
---|
1380 | ;;{{{ Simple section API for XEmacs |
---|
1381 | (defsubst singular-xemacs-simple-sec-start (simple-sec) |
---|
1382 | "Return start of non-clear simple section SIMPLE-SEC. |
---|
1383 | Narrowing has no effect on this function." |
---|
1384 | (extent-start-position simple-sec)) |
---|
1385 | |
---|
1386 | (defsubst singular-xemacs-simple-sec-end (simple-sec) |
---|
1387 | "Return end of non-clear simple section SIMPLE-SEC. |
---|
1388 | Narrowing has no effect on this function." |
---|
1389 | (extent-end-position simple-sec)) |
---|
1390 | |
---|
1391 | (defsubst singular-xemacs-simple-sec-type (simple-sec) |
---|
1392 | "Return type of SIMPLE-SEC. |
---|
1393 | Returns nil if SIMPLE-SEC happens to be an extent but not a simple |
---|
1394 | section. |
---|
1395 | Narrowing has no effect on this function." |
---|
1396 | (if simple-sec |
---|
1397 | (extent-property simple-sec 'singular-type) |
---|
1398 | singular-simple-sec-clear-type)) |
---|
1399 | |
---|
1400 | (defsubst singular-xemacs-simple-sec-before (pos) |
---|
1401 | "Return simple section before buffer position POS. |
---|
1402 | This is the same as `singular-simple-sec-at' except if POS falls on a |
---|
1403 | section border. In this case `singular-simple-section-before' returns the |
---|
1404 | previous simple section instead of the current one. If POS falls on |
---|
1405 | beginning of buffer, the simple section at beginning of buffer is returned. |
---|
1406 | Narrowing has no effect on this function." |
---|
1407 | (singular-xemacs-simple-sec-at (max 1 (1- pos)))) |
---|
1408 | |
---|
1409 | (defun singular-xemacs-simple-sec-create (type end) |
---|
1410 | "Create a new simple section of type TYPE. |
---|
1411 | Creates the section from end of previous simple section up to the first |
---|
1412 | beginning of line before END. That position should be larger than or equal |
---|
1413 | to `singular-simple-sec-last-end'. Updates `singular-simple-sec-last-end'. |
---|
1414 | Returns the new simple section or `empty' if no simple section has been |
---|
1415 | created. |
---|
1416 | Assumes that no narrowing is in effect." |
---|
1417 | (let ((last-end (singular-simple-sec-last-end-position)) |
---|
1418 | ;; `simple-sec' is the new simple section or `empty' |
---|
1419 | simple-sec) |
---|
1420 | |
---|
1421 | ;; get beginning of line before END. At this point we need that there |
---|
1422 | ;; are no restrictions. |
---|
1423 | (setq end (let ((old-point (point))) |
---|
1424 | (goto-char end) (beginning-of-line) |
---|
1425 | (prog1 (point) (goto-char old-point)))) |
---|
1426 | |
---|
1427 | (cond |
---|
1428 | ;; do not create empty sections |
---|
1429 | ((eq end last-end) |
---|
1430 | 'empty) |
---|
1431 | ;; non-clear simple sections |
---|
1432 | ((not (eq type singular-simple-sec-clear-type)) |
---|
1433 | ;; if type has not changed we only have to extend the previous simple |
---|
1434 | ;; section. If `last-end' happens to be 1 (meaning that we are |
---|
1435 | ;; creating the first non-clear simple section in the buffer), then |
---|
1436 | ;; `singular-simple-sec-before' returns nil, |
---|
1437 | ;; `singular-simple-sec-type' returns the type of clear simple |
---|
1438 | ;; sections that definitely does not equal TYPE, and a new simple |
---|
1439 | ;; section is created as necessary. |
---|
1440 | (setq simple-sec (singular-xemacs-simple-sec-before last-end)) |
---|
1441 | (if (eq type (singular-xemacs-simple-sec-type simple-sec)) |
---|
1442 | ;; move existing extent |
---|
1443 | (setq simple-sec (set-extent-endpoints simple-sec |
---|
1444 | (extent-start-position simple-sec) end)) |
---|
1445 | ;; create new extent |
---|
1446 | (setq simple-sec (make-extent last-end end)) |
---|
1447 | ;; set type property |
---|
1448 | (set-extent-property simple-sec 'singular-type type) |
---|
1449 | ;; set face. In contrast to Emacs, we do not need to set somethin |
---|
1450 | ;; like `evaporate'. `detachable' is set by XEmacs by default. |
---|
1451 | (set-extent-property simple-sec 'face (singular-simple-sec-lookup-face type))) |
---|
1452 | ;; update `singular-simple-sec-last-end' and return new simple |
---|
1453 | ;; section |
---|
1454 | (set-marker singular-simple-sec-last-end end) |
---|
1455 | simple-sec) |
---|
1456 | ;; clear simple sections |
---|
1457 | (t |
---|
1458 | ;; update `singular-simple-sec-last-end' and return nil |
---|
1459 | (set-marker singular-simple-sec-last-end end) |
---|
1460 | nil)))) |
---|
1461 | |
---|
1462 | (defun singular-xemacs-simple-sec-start-at (pos) |
---|
1463 | "Return start of clear simple section at position POS. |
---|
1464 | Assumes the existence of an imagenary empty clear simple section if POS is |
---|
1465 | at end of buffer and there is non-clear simple section immediately ending |
---|
1466 | at POS. |
---|
1467 | Assumes that no narrowing is in effect (since `previous-extent-change' |
---|
1468 | imlicitly does so)." |
---|
1469 | ;; get into some hairy details at end of buffer. Look if there is a |
---|
1470 | ;; non-clear simple section immediately ending at end of buffer and |
---|
1471 | ;; return the start of the imagenary empty clear simple section in that |
---|
1472 | ;; case. If buffer is empty this test fails since |
---|
1473 | ;; `singular-xemacs-simple-sec-before' (corretly) returns nil. But in |
---|
1474 | ;; that case the following loop returns the correct result. |
---|
1475 | (if (and (eq pos (point-max)) |
---|
1476 | (singular-xemacs-simple-sec-before pos)) |
---|
1477 | pos |
---|
1478 | (let ((previous-extent-change-pos (min (1+ pos) (point-max)))) |
---|
1479 | ;; this `while' loop at last will run into the end of the next |
---|
1480 | ;; non-clear simple section or stop at bob. Since POS may be right at |
---|
1481 | ;; the end of a previous non-clear location, we have to search at least |
---|
1482 | ;; one time from POS+1 backwards. |
---|
1483 | (while (not (or (singular-xemacs-simple-sec-before previous-extent-change-pos) |
---|
1484 | (eq previous-extent-change-pos 1))) |
---|
1485 | (setq previous-extent-change-pos |
---|
1486 | (previous-extent-change previous-extent-change-pos))) |
---|
1487 | previous-extent-change-pos))) |
---|
1488 | |
---|
1489 | (defun singular-xemacs-simple-sec-end-at (pos) |
---|
1490 | "Return end of clear simple section at position POS. |
---|
1491 | Assumes the existence of an imagenary empty clear simple section if POS is |
---|
1492 | at end of buffer and there is non-clear simple section immediately ending |
---|
1493 | at POS. |
---|
1494 | Assumes that no narrowing is in effect (since `next-extent-change' |
---|
1495 | imlicitly does so)." |
---|
1496 | (let ((next-extent-change-pos (next-extent-change pos))) |
---|
1497 | ;; this `while' loop at last will run into the beginning of the next |
---|
1498 | ;; non-clear simple section or stop at eob. Since POS may not be at |
---|
1499 | ;; the beginning of a non-clear simple section we may start searching |
---|
1500 | ;; immediately. |
---|
1501 | (while (not (or (singular-xemacs-simple-sec-at next-extent-change-pos) |
---|
1502 | (eq next-extent-change-pos (point-max)))) |
---|
1503 | (setq next-extent-change-pos |
---|
1504 | (next-extent-change next-extent-change-pos))) |
---|
1505 | next-extent-change-pos)) |
---|
1506 | |
---|
1507 | (defun singular-xemacs-simple-sec-at (pos) |
---|
1508 | "Return simple section at buffer position POS. |
---|
1509 | Assumes the existence of an imagenary empty clear simple section if POS is |
---|
1510 | at end of buffer and there is non-clear simple section immediately ending |
---|
1511 | at POS. |
---|
1512 | Narrowing has no effect on this function." |
---|
1513 | ;; at eob, `map-extent' always returns nil so everything is OK for this |
---|
1514 | ;; case, too. Do not try to use `extent-at' at this point. `extent-at' |
---|
1515 | ;; does not return extents outside narrowed text. |
---|
1516 | (map-extents (function (lambda (ext args) ext)) |
---|
1517 | nil pos pos nil nil 'singular-type)) |
---|
1518 | |
---|
1519 | (defun singular-xemacs-simple-sec-in (beg end) |
---|
1520 | "Return a list of all simple sections intersecting with the region from BEG to END. |
---|
1521 | A simple section intersects the region if the section and the region have |
---|
1522 | at least one character in common. The sections are returned with |
---|
1523 | startpoints in increasing order and clear simple sections (that is, nil's) |
---|
1524 | inserted as necessary. BEG is assumed to be less than or equal to END. |
---|
1525 | The imagenary empty clear simple section at end of buffer is never included |
---|
1526 | in the result. |
---|
1527 | Narrowing has no effect on this function." |
---|
1528 | (let (extents extent-cursor) |
---|
1529 | (if (= beg end) |
---|
1530 | ;; `mapcar-extents' may return some extents in this case, so |
---|
1531 | ;; exclude it |
---|
1532 | nil |
---|
1533 | ;; OK, that's a little bit easier than for Emacs ... |
---|
1534 | (setq extents (mapcar-extents 'identity nil nil beg end nil 'singular-type)) |
---|
1535 | |
---|
1536 | ;; now we have the list of non-clear simple sections. Go and |
---|
1537 | ;; insert clear simple sections as necessary. |
---|
1538 | (if (null extents) |
---|
1539 | ;; if there are no non-clear simple sections at all there can be |
---|
1540 | ;; only one large clear simple section |
---|
1541 | '(nil) |
---|
1542 | ;; we care about inside clear simple section first |
---|
1543 | (setq extent-cursor extents) |
---|
1544 | (while (cdr extent-cursor) |
---|
1545 | (if (eq (extent-end-position (car extent-cursor)) |
---|
1546 | (extent-start-position (cadr extent-cursor))) |
---|
1547 | (setq extent-cursor (cdr extent-cursor)) |
---|
1548 | ;; insert nil |
---|
1549 | (setcdr extent-cursor |
---|
1550 | (cons nil (cdr extent-cursor))) |
---|
1551 | (setq extent-cursor (cddr extent-cursor)))) |
---|
1552 | ;; now, check BEG and END for clear simple sections |
---|
1553 | (if (> (extent-start-position (car extents)) beg) |
---|
1554 | (setq extents (cons nil extents))) |
---|
1555 | ;; `extent-cursor' still points to the end |
---|
1556 | (if (< (extent-end-position (car extent-cursor)) end) |
---|
1557 | (setcdr extent-cursor (cons nil nil))) |
---|
1558 | extents)))) |
---|
1559 | ;;}}} |
---|
1560 | |
---|
1561 | ;;{{{ Section API |
---|
1562 | |
---|
1563 | ;; Note: |
---|
1564 | ;; |
---|
1565 | ;; Sections are built on simple sections. Their purpose is to cover the |
---|
1566 | ;; difference between clear and non-clear simple sections. |
---|
1567 | ;; |
---|
1568 | ;; - Sections consist of a simple section, its type, and its start and end |
---|
1569 | ;; points. This is redundant information only in the case of non-clear |
---|
1570 | ;; simple section. |
---|
1571 | ;; - Sections are read-only objects, neither are they modified nor are they |
---|
1572 | ;; created. |
---|
1573 | ;; - Buffer narrowing does not restrict the extent of completely or |
---|
1574 | ;; partially inaccessible sections. In contrast to simple sections the |
---|
1575 | ;; functions concerning sections do not assume that there is no narrowing |
---|
1576 | ;; in effect. However, most functions provide an optional argument |
---|
1577 | ;; RESTRICTED that restricts the start and end point of the returned |
---|
1578 | ;; sections to the currently active restrictions. Of course, that does |
---|
1579 | ;; not affect the range of the underlying simple sections, only the |
---|
1580 | ;; additional start and end points being returned. One should note that |
---|
1581 | ;; by restricting sections one may get empty sections, that is, sections |
---|
1582 | ;; for which the additional start and end point are equal. |
---|
1583 | ;; - Sections are independent from implementation dependencies. There are |
---|
1584 | ;; no different versions of the functions for Emacs and XEmacs. |
---|
1585 | ;; - Whenever possible, one should not access simple section directly. |
---|
1586 | ;; Instead, one should use the section API. |
---|
1587 | |
---|
1588 | (defcustom singular-section-face-alist '((input . nil) |
---|
1589 | (output . singular-section-output-face)) |
---|
1590 | "*Alist that maps section types to faces. |
---|
1591 | Should be a list consisting of elements (SECTION-TYPE . FACE-OR-NIL), where |
---|
1592 | SECTION-TYPE is either `input' or `output'. |
---|
1593 | |
---|
1594 | At any time, the Singular interactive mode buffer is completely covered by |
---|
1595 | sections of two different types: input sections and output sections. This |
---|
1596 | variable determines which faces are used to display the different sections. |
---|
1597 | |
---|
1598 | If for type SECTION-TYPE the value FACE-OR-NIL is a face it is used to |
---|
1599 | display the contents of all sections of that particular type. |
---|
1600 | If instead FACE-OR-NIL equals nil sections of that type become so-called |
---|
1601 | clear sections. The content of clear sections is displayed as regular |
---|
1602 | text, with no faces at all attached to them. |
---|
1603 | |
---|
1604 | Some notes and restrictions on this variable (believe them or not): |
---|
1605 | o Changing this variable during a Singular session may cause unexpected |
---|
1606 | results (but not too serious ones, though). |
---|
1607 | o There may be only one clear section type defined at a time. |
---|
1608 | o Choosing clear input sections is a good idea. |
---|
1609 | o Choosing clear output sections is a bad idea. |
---|
1610 | o Consequence: Not to change this variable is a good idea." |
---|
1611 | ;; to add new section types, simply extend the `list' widget. |
---|
1612 | ;; The rest should work unchanged. Do not forget to update docu. |
---|
1613 | :type '(list (cons :tag "Input sections" |
---|
1614 | (const :format "" input) |
---|
1615 | (choice :format |
---|
1616 | "Choose either clear or non-clear input sections. For non-clear sections, |
---|
1617 | select or modify a face (preferably `singular-section-input-face') used to |
---|
1618 | display the sections. |
---|
1619 | %[Choice%] |
---|
1620 | %v |
---|
1621 | " |
---|
1622 | (const :tag "Clear sections" nil) |
---|
1623 | (face :tag "Non-clear sections"))) |
---|
1624 | (cons :tag "Output sections" |
---|
1625 | (const :format "" output) |
---|
1626 | (choice :format |
---|
1627 | "Choose either clear or non-clear ouput sections. For non-clear sections, |
---|
1628 | select or modify a face (preferably `singular-section-output-face') used to |
---|
1629 | display the sections. |
---|
1630 | %[Choice%] |
---|
1631 | %v |
---|
1632 | " |
---|
1633 | (const :tag "Clear sections" nil) |
---|
1634 | (face :tag "Non-clear sections")))) |
---|
1635 | :initialize 'custom-initialize-reset |
---|
1636 | ;; this function checks for validity (only one clear section |
---|
1637 | ;; type) and sets `singular-simple-sec-clear-type' accordingly. |
---|
1638 | ;; In case of an error, nothing is set or modified. |
---|
1639 | :set (function (lambda (var value) |
---|
1640 | (let* ((cdrs-with-nils (mapcar 'cdr value)) |
---|
1641 | (cdrs-without-nils (delq nil (copy-sequence cdrs-with-nils)))) |
---|
1642 | (if (> (- (length cdrs-with-nils) (length cdrs-without-nils)) 1) |
---|
1643 | (error "Only one clear section type allowed (see `singular-section-face-alist')") |
---|
1644 | (set-default var value) |
---|
1645 | (setq singular-simple-sec-clear-type (car (rassq nil value))))))) |
---|
1646 | :group 'singular-faces |
---|
1647 | :group 'singular-sections-and-foldings) |
---|
1648 | |
---|
1649 | (defface singular-section-input-face '((t nil)) |
---|
1650 | "*Face to use for input sections. |
---|
1651 | It may be not sufficient to modify this face to change the appearance of |
---|
1652 | input sections. See `singular-section-face-alist' for more information." |
---|
1653 | :group 'singular-faces |
---|
1654 | :group 'singular-sections-and-foldings) |
---|
1655 | |
---|
1656 | (defface singular-section-output-face '((t (:bold t))) |
---|
1657 | "*Face to use for output sections. |
---|
1658 | It may be not sufficient to modify this face to change the appearance of |
---|
1659 | output sections. See `singular-section-face-alist' for more information." |
---|
1660 | :group 'singular-faces |
---|
1661 | :group 'singular-sections-and-foldings) |
---|
1662 | |
---|
1663 | (defsubst singular-section-create (simple-sec type start end) |
---|
1664 | "Create and return a new section." |
---|
1665 | (vector simple-sec type start end)) |
---|
1666 | |
---|
1667 | (defsubst singular-section-simple-sec (section) |
---|
1668 | "Return underlying simple section of SECTION." |
---|
1669 | (aref section 0)) |
---|
1670 | |
---|
1671 | (defsubst singular-section-type (section) |
---|
1672 | "Return type of SECTION." |
---|
1673 | (aref section 1)) |
---|
1674 | |
---|
1675 | (defsubst singular-section-start (section) |
---|
1676 | "Return start of SECTION." |
---|
1677 | (aref section 2)) |
---|
1678 | |
---|
1679 | (defsubst singular-section-end (section) |
---|
1680 | "Return end of SECTION." |
---|
1681 | (aref section 3)) |
---|
1682 | |
---|
1683 | (defun singular-section-at (pos &optional restricted) |
---|
1684 | "Return section at position POS. |
---|
1685 | Returns section intersected with current restriction if RESTRICTED is |
---|
1686 | non-nil." |
---|
1687 | (let* ((simple-sec (singular-simple-sec-at pos)) |
---|
1688 | (type (singular-simple-sec-type simple-sec)) |
---|
1689 | start end) |
---|
1690 | (if simple-sec |
---|
1691 | (setq start (singular-simple-sec-start simple-sec) |
---|
1692 | end (singular-simple-sec-end simple-sec)) |
---|
1693 | (save-restriction |
---|
1694 | (widen) |
---|
1695 | (setq start (singular-simple-sec-start-at pos) |
---|
1696 | end (singular-simple-sec-end-at pos)))) |
---|
1697 | (cond |
---|
1698 | ;; not restricted first |
---|
1699 | ((not restricted) |
---|
1700 | (singular-section-create simple-sec type start end)) |
---|
1701 | ;; restricted and degenerated |
---|
1702 | ((and restricted |
---|
1703 | (< end (point-min))) |
---|
1704 | (singular-section-create simple-sec type (point-min) (point-min))) |
---|
1705 | ;; restricted and degenerated |
---|
1706 | ((and restricted |
---|
1707 | (> start (point-max))) |
---|
1708 | (singular-section-create simple-sec type (point-max) (point-max))) |
---|
1709 | ;; restricted but not degenrated |
---|
1710 | (t |
---|
1711 | (singular-section-create simple-sec type |
---|
1712 | (max start (point-min)) |
---|
1713 | (min end (point-max))))))) |
---|
1714 | |
---|
1715 | (defun singular-section-before (pos &optional restricted) |
---|
1716 | "Return section before position POS. |
---|
1717 | This is the same as `singular-section-at' except if POS falls on a section |
---|
1718 | border. In this case `singular-section-before' returns the previous |
---|
1719 | section instead of the current one. If POS falls on beginning of buffer, |
---|
1720 | the section at beginning of buffer is returned. |
---|
1721 | Returns section intersected with current restriction if RESTRICTED is |
---|
1722 | non-nil." |
---|
1723 | (singular-section-at (max 1 (1- pos)) restricted)) |
---|
1724 | |
---|
1725 | (defun singular-section-in (beg end &optional restricted) |
---|
1726 | "Return a list of all sections intersecting with the region from BEG to END. |
---|
1727 | A section intersects with the region if the section and the region have at |
---|
1728 | least one character in common. The sections are returned in increasing |
---|
1729 | order. |
---|
1730 | If optional argument RESTRICTED is non-nil only sections which are |
---|
1731 | completely in the intersection of the region and the current restriction |
---|
1732 | are returned." |
---|
1733 | ;; exchange BEG and END if necessary as a special service to our users |
---|
1734 | (let* ((reg-beg (min beg end)) |
---|
1735 | (reg-end (max beg end)) |
---|
1736 | ;; we need these since we widen the buffer later on |
---|
1737 | (point-min (point-min)) |
---|
1738 | (point-max (point-max)) |
---|
1739 | simple-sections) |
---|
1740 | (if (and restricted |
---|
1741 | (or (> reg-beg point-max) (< reg-end point-min))) |
---|
1742 | ;; degenerate restrictions |
---|
1743 | nil |
---|
1744 | ;; do the intersection if necessary and get simple sections |
---|
1745 | (setq reg-beg (if restricted (max reg-beg point-min) reg-beg) |
---|
1746 | reg-end (if restricted (min reg-end point-max) reg-end) |
---|
1747 | simple-sections (singular-simple-sec-in reg-beg reg-end)) |
---|
1748 | ;; we still have REG-BEG <= REG-END in any case. SIMPLE-SECTIONS |
---|
1749 | ;; contains the list of simple sections intersecting with the region |
---|
1750 | ;; from REG-BEG and REG-END. |
---|
1751 | |
---|
1752 | (if (null simple-sections) |
---|
1753 | nil |
---|
1754 | ;; and here we even have REG-BEG < REG-END |
---|
1755 | (save-restriction |
---|
1756 | (widen) |
---|
1757 | ;; get sections intersecting with the region from REG-BEG to |
---|
1758 | ;; REG-END |
---|
1759 | (let* ((sections (singular-section-in-internal simple-sections |
---|
1760 | reg-beg reg-end)) |
---|
1761 | first-section-start last-section-end) |
---|
1762 | (if (not restricted) |
---|
1763 | sections |
---|
1764 | (setq first-section-start (singular-section-start (car sections)) |
---|
1765 | last-section-end (singular-section-end (car (last sections)))) |
---|
1766 | ;; popping off first element is easy ... |
---|
1767 | (if (< first-section-start point-min) |
---|
1768 | (setq sections (cdr sections))) |
---|
1769 | ;; ... but last element is harder to pop off |
---|
1770 | (cond |
---|
1771 | (;; no elements left |
---|
1772 | (null sections) |
---|
1773 | nil) |
---|
1774 | (;; one element left |
---|
1775 | (null (cdr sections)) |
---|
1776 | (if (> last-section-end point-max) |
---|
1777 | nil |
---|
1778 | sections)) |
---|
1779 | (;; more than one element left |
---|
1780 | t |
---|
1781 | (if (> last-section-end point-max) |
---|
1782 | (setcdr (last sections 2) nil)) |
---|
1783 | sections))))))))) |
---|
1784 | |
---|
1785 | (defun singular-section-in-internal (simple-sections reg-beg reg-end) |
---|
1786 | "Create a list of sections from SIMPLE-SECTIONS. |
---|
1787 | This is the back-end for `singular-section-in'. |
---|
1788 | First simple section should be such that it contains REG-BEG, last simple |
---|
1789 | section should be such that it contains or ends at REG-END. These |
---|
1790 | arguments are used to find the start resp. end of clear simple sections of |
---|
1791 | terminal clear simple sections in SIMPLE-SECTIONS. |
---|
1792 | Assumes that REG-BEG < REG-END. |
---|
1793 | Assumes that SIMPLE-SECTIONS is not empty. |
---|
1794 | Assumes that no narrowing is in effect." |
---|
1795 | (let* (;; we pop off the extra nil at the end of the loop |
---|
1796 | (sections (cons nil nil)) |
---|
1797 | (sections-end sections) |
---|
1798 | (simple-section (car simple-sections)) |
---|
1799 | type start end) |
---|
1800 | |
---|
1801 | ;; first, get unrestricted start |
---|
1802 | (setq start (if simple-section |
---|
1803 | (singular-simple-sec-start simple-section) |
---|
1804 | ;; here we need that no narrowing is in effect |
---|
1805 | (singular-simple-sec-start-at reg-beg))) |
---|
1806 | |
---|
1807 | ;; loop through all simple sections but last |
---|
1808 | (while (cdr simple-sections) |
---|
1809 | (setq simple-section (car simple-sections) |
---|
1810 | type (singular-simple-sec-type simple-section) |
---|
1811 | end (if simple-section |
---|
1812 | (singular-simple-sec-end simple-section) |
---|
1813 | (singular-simple-sec-start (cadr simple-sections))) |
---|
1814 | |
---|
1815 | ;; append the new section to `sections-end' |
---|
1816 | sections-end |
---|
1817 | (setcdr sections-end |
---|
1818 | (cons (singular-section-create simple-section type start end) nil)) |
---|
1819 | |
---|
1820 | ;; get next simple section and its start |
---|
1821 | simple-sections (cdr simple-sections) |
---|
1822 | start end)) |
---|
1823 | |
---|
1824 | ;; care about last simple section |
---|
1825 | (setq simple-section (car simple-sections) |
---|
1826 | type (singular-simple-sec-type simple-section) |
---|
1827 | end (if simple-section |
---|
1828 | (singular-simple-sec-end simple-section) |
---|
1829 | ;; the `1-' is OK since REG-BEG < REG-END. |
---|
1830 | ;; here we need that no narrowing is in effect |
---|
1831 | (singular-simple-sec-end-at (1- reg-end)))) |
---|
1832 | (setcdr sections-end |
---|
1833 | (cons (singular-section-create simple-section type start end) nil)) |
---|
1834 | |
---|
1835 | ;; we should not forget to pop off our auxilliary cons-cell |
---|
1836 | (cdr sections))) |
---|
1837 | |
---|
1838 | (defun singular-section-mapsection (func sections &optional type-filter negate-filter) |
---|
1839 | "Apply FUNC to each section in SECTIONS, and make a list of the results. |
---|
1840 | If optional argument TYPE-FILTER is non-nil it should be a list of section |
---|
1841 | types. FUNC is then applied only to those sections with type occuring in |
---|
1842 | TYPE-FILTER. If in addition optional argument NEGATE-FILTER is non-nil |
---|
1843 | FUNC is applied only to those sections with type not occuring in |
---|
1844 | TYPE-FILTER. |
---|
1845 | |
---|
1846 | In any case the length of the list this function returns equals the |
---|
1847 | number of sections actually processed." |
---|
1848 | (if (not type-filter) |
---|
1849 | (mapcar func sections) |
---|
1850 | ;; copy the list first |
---|
1851 | (let ((sections (copy-sequence sections))) |
---|
1852 | ;; filter elements and turn them to t's |
---|
1853 | (setq sections |
---|
1854 | (mapcar (function |
---|
1855 | (lambda (section) |
---|
1856 | ;; that strange expression evaluates to t iff the |
---|
1857 | ;; section should be removed. The `not' is to |
---|
1858 | ;; canonize boolean values to t or nil, resp. |
---|
1859 | (or (eq (not (memq (singular-section-type section) type-filter)) |
---|
1860 | (not negate-filter)) |
---|
1861 | section))) |
---|
1862 | sections) |
---|
1863 | |
---|
1864 | ;; remove t's now |
---|
1865 | sections (delq t sections)) |
---|
1866 | |
---|
1867 | ;; call function for remaining sections |
---|
1868 | (mapcar func sections)))) |
---|
1869 | ;;}}} |
---|
1870 | |
---|
1871 | ;;{{{ Section miscellaneous |
---|
1872 | (defun singular-input-section-to-string (section &optional end raw) |
---|
1873 | "Get content of input section SECTION as string. |
---|
1874 | Returns text between start of SECTION and END if optional argument END is |
---|
1875 | non-nil, otherwise text between start and end of SECTION. END should be a |
---|
1876 | position inside SECTION. |
---|
1877 | Strips leading prompts and trailing white space unless optional argument |
---|
1878 | RAW is non-nil." |
---|
1879 | (save-restriction |
---|
1880 | (widen) |
---|
1881 | (let ((string (buffer-substring (singular-section-start section) |
---|
1882 | (or end (singular-section-end section))))) |
---|
1883 | (if raw |
---|
1884 | string |
---|
1885 | (singular-strip-leading-prompt (singular-strip-white-space string t)))))) |
---|
1886 | ;;}}} |
---|
1887 | |
---|
1888 | ;;{{{ Section miscellaneous interactive |
---|
1889 | (defun singular-section-goto-beginning () |
---|
1890 | "Move point to beginning of current section." |
---|
1891 | (interactive) |
---|
1892 | (goto-char (singular-section-start (singular-section-at (point)))) |
---|
1893 | (singular-keep-region-active)) |
---|
1894 | |
---|
1895 | (defun singular-section-goto-end () |
---|
1896 | "Move point to end of current section." |
---|
1897 | (interactive) |
---|
1898 | (goto-char (singular-section-end (singular-section-at (point)))) |
---|
1899 | (singular-keep-region-active)) |
---|
1900 | |
---|
1901 | (defun singular-section-backward (n) |
---|
1902 | "Move backward until encountering the beginning of a section. |
---|
1903 | With argument, do this that many times. With N less than zero, call |
---|
1904 | `singular-section-forward' with argument -N." |
---|
1905 | (interactive "p") |
---|
1906 | (while (> n 0) |
---|
1907 | (goto-char (singular-section-start (singular-section-before (point)))) |
---|
1908 | (setq n (1- n))) |
---|
1909 | (if (< n 0) |
---|
1910 | (singular-section-forward (- n)) |
---|
1911 | (singular-keep-region-active))) |
---|
1912 | |
---|
1913 | (defun singular-section-forward (n) |
---|
1914 | "Move forward until encountering the end of a section. |
---|
1915 | With argument, do this that many times. With N less than zero, call |
---|
1916 | `singular-section-backward' with argument -N." |
---|
1917 | (interactive "p") |
---|
1918 | (while (> n 0) |
---|
1919 | (goto-char (singular-section-end (singular-section-at (point)))) |
---|
1920 | (setq n (1- n))) |
---|
1921 | (if (< n 0) |
---|
1922 | (singular-section-backward (- n)) |
---|
1923 | (singular-keep-region-active))) |
---|
1924 | ;;}}} |
---|
1925 | |
---|
1926 | ;;{{{ Folding sections for both Emacs and XEmacs |
---|
1927 | (defcustom singular-folding-ellipsis "Singular I/O ..." |
---|
1928 | "*Ellipsis to show for folded input or output. |
---|
1929 | Changing this variable has an immediate effect only if one uses |
---|
1930 | \\[customize] to do so. |
---|
1931 | However, even then it may be necessary to refresh display completely (using |
---|
1932 | \\[recenter], for example) for the new settings to be visible." |
---|
1933 | :type 'string |
---|
1934 | :initialize 'custom-initialize-default |
---|
1935 | :set (function |
---|
1936 | (lambda (var value) |
---|
1937 | ;; set in all singular buffers |
---|
1938 | (singular-map-buffer 'singular-folding-set-ellipsis value) |
---|
1939 | (set-default var value))) |
---|
1940 | :group 'singular-sections-and-foldings) |
---|
1941 | |
---|
1942 | (defcustom singular-folding-line-move-ignore-folding t |
---|
1943 | "*If non-nil, ignore folded sections when moving point up or down. |
---|
1944 | This variable is used to initialize `line-move-ignore-invisible'. However, |
---|
1945 | documentation states that setting `line-move-ignore-invisible' to a non-nil |
---|
1946 | value may result in a slow-down when moving the point up or down. One |
---|
1947 | should try to set this variable to nil if point motion seems too slow. |
---|
1948 | |
---|
1949 | Changing this variable has an immediate effect only if one uses |
---|
1950 | \\[customize] to do so." |
---|
1951 | :type 'boolean |
---|
1952 | :initialize 'custom-initialize-default |
---|
1953 | :set (function |
---|
1954 | (lambda (var value) |
---|
1955 | ;; set in all singular buffers |
---|
1956 | (singular-map-buffer 'set 'line-move-ignore-invisible value) |
---|
1957 | (set-default var value))) |
---|
1958 | :group 'singular-sections-and-foldings) |
---|
1959 | |
---|
1960 | (defun singular-folding-set-ellipsis (ellipsis) |
---|
1961 | "Set ellipsis to show for folded input or output in current buffer." |
---|
1962 | (cond |
---|
1963 | ;; Emacs |
---|
1964 | ((eq singular-emacs-flavor 'emacs) |
---|
1965 | (setq buffer-display-table (or (copy-sequence standard-display-table) |
---|
1966 | (make-display-table))) |
---|
1967 | (set-display-table-slot buffer-display-table |
---|
1968 | 'selective-display (vconcat ellipsis))) |
---|
1969 | ;; XEmacs |
---|
1970 | (t |
---|
1971 | (set-glyph-image invisible-text-glyph ellipsis (current-buffer))))) |
---|
1972 | |
---|
1973 | (defun singular-folding-init () |
---|
1974 | "Initializes folding of sections for the current buffer. |
---|
1975 | That includes setting `buffer-invisibility-spec' and the ellipsis to show |
---|
1976 | for hidden text. |
---|
1977 | |
---|
1978 | This function is called at mode initialization time." |
---|
1979 | ;; initialize `buffer-invisibility-spec' first |
---|
1980 | (let ((singular-invisibility-spec (cons 'singular-interactive-mode t))) |
---|
1981 | (if (and (listp buffer-invisibility-spec) |
---|
1982 | (not (member singular-invisibility-spec buffer-invisibility-spec))) |
---|
1983 | (setq buffer-invisibility-spec |
---|
1984 | (cons singular-invisibility-spec buffer-invisibility-spec)) |
---|
1985 | (setq buffer-invisibility-spec (list singular-invisibility-spec)))) |
---|
1986 | ;; ignore invisible lines on movements |
---|
1987 | (set (make-local-variable 'line-move-ignore-invisible) |
---|
1988 | singular-folding-line-move-ignore-folding) |
---|
1989 | ;; now for the ellipsis |
---|
1990 | (singular-folding-set-ellipsis singular-folding-ellipsis)) |
---|
1991 | |
---|
1992 | (defun singular-folding-fold (section &optional no-error) |
---|
1993 | "Fold section SECTION if it is not already folded. |
---|
1994 | Does not fold sections that do not end in a newline or that are restricted |
---|
1995 | either in part or as a whole. Rather fails with an error in such cases |
---|
1996 | or silently fails if optional argument NO-ERROR is non-nil. |
---|
1997 | This is for safety only: In both cases the result may be confusing to the |
---|
1998 | user." |
---|
1999 | (let* ((start (singular-section-start section)) |
---|
2000 | (end (singular-section-end section))) |
---|
2001 | (cond ((or (< start (point-min)) |
---|
2002 | (> end (point-max))) |
---|
2003 | (unless no-error |
---|
2004 | (error "Folding not possible: section is restricted in part or as a whole"))) |
---|
2005 | ((not (eq (char-before end) ?\n)) |
---|
2006 | (unless no-error |
---|
2007 | (error "Folding not possible: section does not end in newline"))) |
---|
2008 | ((not (singular-folding-foldedp section)) |
---|
2009 | ;; fold but only if not already folded |
---|
2010 | (singular-folding-fold-internal section))))) |
---|
2011 | |
---|
2012 | (defun singular-folding-unfold (section &optional no-error invisibility-overlay-or-extent) |
---|
2013 | "Unfold section SECTION if it is not already unfolded. |
---|
2014 | Does not unfold sections that are restricted either in part or as a whole. |
---|
2015 | Rather fails with an error in such cases or silently fails if optional |
---|
2016 | argument NO-ERROR is non-nil. This is for safety only: The result may be |
---|
2017 | confusing to the user. |
---|
2018 | If optional argument INVISIBILITY-OVERLAY-OR_EXTENT is non-nil it should be |
---|
2019 | the invisibility overlay or extent, respectively, of the section to |
---|
2020 | unfold." |
---|
2021 | (let* ((start (singular-section-start section)) |
---|
2022 | (end (singular-section-end section))) |
---|
2023 | (cond ((or (< start (point-min)) |
---|
2024 | (> end (point-max))) |
---|
2025 | (unless no-error |
---|
2026 | (error "Unfolding not possible: section is restricted in part or as a whole"))) |
---|
2027 | ((or invisibility-overlay-or-extent |
---|
2028 | (setq invisibility-overlay-or-extent (singular-folding-foldedp section))) |
---|
2029 | ;; unfold but only if not already unfolded |
---|
2030 | (singular-folding-unfold-internal section invisibility-overlay-or-extent))))) |
---|
2031 | |
---|
2032 | (defun singular-folding-fold-at-point () |
---|
2033 | "Fold section point currently is in. |
---|
2034 | Does not fold sections that do not end in a newline or that are restricted |
---|
2035 | either in part or as a whole. Rather fails with an error in such cases." |
---|
2036 | (interactive) |
---|
2037 | (singular-folding-fold (singular-section-at (point)))) |
---|
2038 | |
---|
2039 | (defun singular-folding-unfold-at-point () |
---|
2040 | "Unfold section point currently is in. |
---|
2041 | Does not unfold sections that are restricted either in part or as a whole. |
---|
2042 | Rather fails with an error in such cases." |
---|
2043 | (interactive) |
---|
2044 | (singular-folding-unfold (singular-section-at (point)))) |
---|
2045 | |
---|
2046 | (defun singular-folding-fold-latest-output () |
---|
2047 | "Fold latest output section. |
---|
2048 | Does not fold sections that do not end in a newline or that are restricted |
---|
2049 | either in part or as a whole. Rather fails with an error in such cases." |
---|
2050 | (interactive) |
---|
2051 | (singular-folding-fold (singular-latest-output-section))) |
---|
2052 | |
---|
2053 | (defun singular-folding-unfold-latest-output () |
---|
2054 | "Unfolds latest output section. |
---|
2055 | Does not unfold sections that are restricted either in part or as a whole. |
---|
2056 | Rather fails with an error in such cases." |
---|
2057 | (interactive) |
---|
2058 | (singular-folding-unfold (singular-latest-output-section))) |
---|
2059 | |
---|
2060 | (defun singular-folding-fold-all-output () |
---|
2061 | "Fold all complete, unfolded output sections. |
---|
2062 | That is, all output sections that are not restricted in part or as a whole |
---|
2063 | and that end in a newline." |
---|
2064 | (interactive) |
---|
2065 | (singular-section-mapsection (function (lambda (section) (singular-folding-fold section t))) |
---|
2066 | (singular-section-in (point-min) (point-max) t) |
---|
2067 | '(output))) |
---|
2068 | |
---|
2069 | (defun singular-folding-unfold-all-output () |
---|
2070 | "Unfold all complete, folded output sections. |
---|
2071 | That is, all output sections that are not restricted in part or as a whole." |
---|
2072 | (interactive) |
---|
2073 | (singular-section-mapsection (function (lambda (section) (singular-folding-unfold section t))) |
---|
2074 | (singular-section-in (point-min) (point-max) t) |
---|
2075 | '(output))) |
---|
2076 | |
---|
2077 | (defun singular-folding-toggle-fold-at-point-or-all (&optional arg) |
---|
2078 | "Fold or unfold section point currently is in or all output sections. |
---|
2079 | Without prefix argument, folds unfolded sections and unfolds folded |
---|
2080 | sections. With prefix argument, folds all output sections if argument is |
---|
2081 | positive, otherwise unfolds all output sections. |
---|
2082 | Does neither fold nor unfold sections that do not end in a newline or that |
---|
2083 | are restricted either in part or as a whole. Rather fails with an error in |
---|
2084 | such cases." |
---|
2085 | (interactive "P") |
---|
2086 | (cond ((not arg) |
---|
2087 | ;; fold or unfold section at point |
---|
2088 | (let* ((section (singular-section-at (point))) |
---|
2089 | (invisibility-overlay-or-extent (singular-folding-foldedp section))) |
---|
2090 | (if invisibility-overlay-or-extent |
---|
2091 | (singular-folding-unfold section nil invisibility-overlay-or-extent) |
---|
2092 | (singular-folding-fold section)))) |
---|
2093 | ((> (prefix-numeric-value arg) 0) |
---|
2094 | (singular-folding-fold-all-output)) |
---|
2095 | (t |
---|
2096 | (singular-folding-unfold-all-output)))) |
---|
2097 | |
---|
2098 | (defun singular-folding-toggle-fold-latest-output (&optional arg) |
---|
2099 | "Fold or unfold latest output section. |
---|
2100 | Folds unfolded sections and unfolds folded sections. |
---|
2101 | Does neither fold nor unfold sections that do not end in a newline or that |
---|
2102 | are restricted either in part or as a whole. Rather fails with an error in |
---|
2103 | such cases." |
---|
2104 | (interactive) |
---|
2105 | (let* ((section (singular-latest-output-section)) |
---|
2106 | (invisibility-overlay-or-extent (singular-folding-foldedp section))) |
---|
2107 | (if invisibility-overlay-or-extent |
---|
2108 | (singular-folding-unfold section nil invisibility-overlay-or-extent) |
---|
2109 | (singular-folding-fold section)))) |
---|
2110 | |
---|
2111 | ;; Note: |
---|
2112 | ;; |
---|
2113 | ;; The rest of the folding is either marked as |
---|
2114 | ;; Emacs |
---|
2115 | ;; or |
---|
2116 | ;; XEmacs |
---|
2117 | |
---|
2118 | (singular-fset 'singular-folding-fold-internal |
---|
2119 | 'singular-emacs-folding-fold-internal |
---|
2120 | 'singular-xemacs-folding-fold-internal) |
---|
2121 | |
---|
2122 | (singular-fset 'singular-folding-unfold-internal |
---|
2123 | 'singular-emacs-folding-unfold-internal |
---|
2124 | 'singular-xemacs-folding-unfold-internal) |
---|
2125 | |
---|
2126 | (singular-fset 'singular-folding-foldedp |
---|
2127 | 'singular-emacs-folding-foldedp-internal |
---|
2128 | 'singular-xemacs-folding-foldedp-internal) |
---|
2129 | ;;}}} |
---|
2130 | |
---|
2131 | ;;{{{ Folding sections for Emacs |
---|
2132 | |
---|
2133 | ;; Note: |
---|
2134 | ;; |
---|
2135 | ;; For Emacs, we use overlays to hide text (so-called "invisibility |
---|
2136 | ;; overlays"). In addition to their `invisible' property, they have the |
---|
2137 | ;; `singular-invisible' property set. Setting the intangible property does |
---|
2138 | ;; not work very well for Emacs. We use the variable |
---|
2139 | ;; `line-move-ignore-invisible' which works quite well. |
---|
2140 | |
---|
2141 | (defun singular-emacs-folding-fold-internal (section) |
---|
2142 | "Fold section SECTION. |
---|
2143 | SECTION should end in a newline. That terminal newline is not |
---|
2144 | folded or otherwise ellipsis does not appear. |
---|
2145 | SECTION should be unfolded." |
---|
2146 | (let* ((start (singular-section-start section)) |
---|
2147 | ;; do not make trailing newline invisible |
---|
2148 | (end (1- (singular-section-end section))) |
---|
2149 | invisibility-overlay) |
---|
2150 | ;; create new overlay and add properties |
---|
2151 | (setq invisibility-overlay (make-overlay start end)) |
---|
2152 | ;; mark them as invisibility overlays |
---|
2153 | (overlay-put invisibility-overlay 'singular-invisible t) |
---|
2154 | ;; set invisible properties |
---|
2155 | (overlay-put invisibility-overlay 'invisible 'singular-interactive-mode) |
---|
2156 | ;; evaporate empty invisibility overlays |
---|
2157 | (overlay-put invisibility-overlay 'evaporate t))) |
---|
2158 | |
---|
2159 | (defun singular-emacs-folding-unfold-internal (section &optional invisibility-overlay) |
---|
2160 | "Unfold section SECTION. |
---|
2161 | SECTION should be folded. |
---|
2162 | If optional argument INVISIBILITY-OVERLAY is non-nil it should be the |
---|
2163 | invisibility overlay of the section to unfold." |
---|
2164 | (let ((invisibility-overlay |
---|
2165 | (or invisibility-overlay |
---|
2166 | (singular-emacs-folding-foldedp-internal section)))) |
---|
2167 | ;; to keep number of overlays low we delete it |
---|
2168 | (delete-overlay invisibility-overlay))) |
---|
2169 | |
---|
2170 | (defun singular-emacs-folding-foldedp-internal (section) |
---|
2171 | "Returns non-nil iff SECTION is folded. |
---|
2172 | More specifically, returns the invisibility overlay if there is one. |
---|
2173 | Narrowing has no effect on this function." |
---|
2174 | (let* ((start (singular-section-start section)) |
---|
2175 | (overlays (overlays-at start)) |
---|
2176 | invisibility-overlay) |
---|
2177 | ;; check for invisibility overlay |
---|
2178 | (while (and overlays (not invisibility-overlay)) |
---|
2179 | (if (overlay-get (car overlays) 'singular-invisible) |
---|
2180 | (setq invisibility-overlay (car overlays)) |
---|
2181 | (setq overlays (cdr overlays)))) |
---|
2182 | invisibility-overlay)) |
---|
2183 | ;;}}} |
---|
2184 | |
---|
2185 | ;;{{{ Folding sections for XEmacs |
---|
2186 | |
---|
2187 | ;; Note: |
---|
2188 | ;; |
---|
2189 | ;; For XEmacs, we use extents to hide text (so-called "invisibility |
---|
2190 | ;; extents"). In addition to their `invisible' property, they have the |
---|
2191 | ;; `singular-invisible' property set. To ignore invisible text we use the |
---|
2192 | ;; variable `line-move-ignore-invisible' which works quite well. |
---|
2193 | |
---|
2194 | (defun singular-xemacs-folding-fold-internal (section) |
---|
2195 | "Fold section SECTION. |
---|
2196 | SECTION should end in a newline. That terminal newline is not |
---|
2197 | folded or otherwise ellipsis does not appear. |
---|
2198 | SECTION should be unfolded." |
---|
2199 | (let* ((start (singular-section-start section)) |
---|
2200 | ;; do not make trailing newline invisible |
---|
2201 | (end (1- (singular-section-end section))) |
---|
2202 | invisibility-extent) |
---|
2203 | ;; create new extent and add properties |
---|
2204 | (setq invisibility-extent (make-extent start end)) |
---|
2205 | ;; mark them as invisibility extents |
---|
2206 | (set-extent-property invisibility-extent 'singular-invisible t) |
---|
2207 | ;; set invisible properties |
---|
2208 | (set-extent-property invisibility-extent 'invisible 'singular-interactive-mode))) |
---|
2209 | |
---|
2210 | (defun singular-xemacs-folding-unfold-internal (section &optional invisibility-extent) |
---|
2211 | "Unfold section SECTION. |
---|
2212 | SECTION should be folded. |
---|
2213 | If optional argument INVISIBILITY-EXTENT is non-nil it should be the |
---|
2214 | invisibility extent of the section to unfold." |
---|
2215 | (let ((invisibility-extent |
---|
2216 | (or invisibility-extent |
---|
2217 | (singular-xemacs-folding-foldedp-internal section)))) |
---|
2218 | ;; to keep number of extents low we delete it |
---|
2219 | (delete-extent invisibility-extent))) |
---|
2220 | |
---|
2221 | (defun singular-xemacs-folding-foldedp-internal (section) |
---|
2222 | "Returns non-nil iff SECTION is folded. |
---|
2223 | More specifically, returns the invisibility extent if there is one. |
---|
2224 | Narrowing has no effect on this function." |
---|
2225 | ;; do not try to use `extent-at' at this point. `extent-at' does not |
---|
2226 | ;; return extents outside narrowed text. |
---|
2227 | (let* ((start (singular-section-start section)) |
---|
2228 | (invisibility-extent (map-extents |
---|
2229 | (function (lambda (ext args) ext)) |
---|
2230 | nil start start nil nil 'singular-invisible))) |
---|
2231 | invisibility-extent)) |
---|
2232 | ;;}}} |
---|
2233 | |
---|
2234 | ;;{{{ Online help |
---|
2235 | |
---|
2236 | ;; Note: |
---|
2237 | ;; |
---|
2238 | ;; Catching user's help commands to Singular and translating them to calls |
---|
2239 | ;; to `info' is quite a difficult task due to the asynchronous |
---|
2240 | ;; communication with Singular. We use an heuristic approach which should |
---|
2241 | ;; work in most cases: |
---|
2242 | |
---|
2243 | (require 'info) |
---|
2244 | |
---|
2245 | (defcustom singular-help-same-window 'default |
---|
2246 | "Specifies how to open the window for Singular online help. |
---|
2247 | If this variable equals `default', the standard Emacs behaviour to open the |
---|
2248 | Info buffer is adopted (which very much depends on the settings of |
---|
2249 | `same-window-buffer-names'). |
---|
2250 | If this variable is non-nil, Singular online help comes up in the selected |
---|
2251 | window. |
---|
2252 | If this variable equals nil, Singular online help comes up in another |
---|
2253 | window." |
---|
2254 | :initialize 'custom-initialize-default |
---|
2255 | :type '(choice (const :tag "This window" t) |
---|
2256 | (const :tag "Other window" nil) |
---|
2257 | (const :tag "Default" default)) |
---|
2258 | :group 'singular-interactive-miscellaneous) |
---|
2259 | |
---|
2260 | (defcustom singular-help-explicit-file-name nil |
---|
2261 | "Specifies the file name of the Singular online manual. |
---|
2262 | If non-nil, this variable overrides all other possible ways to determine |
---|
2263 | the file name of the Singular online manual. |
---|
2264 | For more information one should refer to the `singular-help' function." |
---|
2265 | :initialize 'custom-initialize-default |
---|
2266 | :type 'file |
---|
2267 | :group 'singular-interactive-miscellaneous) |
---|
2268 | |
---|
2269 | (defvar singular-help-time-stamp 0 |
---|
2270 | "A time stamp set by `singular-help-pre-input-hook'. |
---|
2271 | This time stamp is set to `(current-time)' when the user issues a help |
---|
2272 | command. To be true, not the whole time stamp is stored, only the less |
---|
2273 | significant half. |
---|
2274 | |
---|
2275 | This variable is buffer-local.") |
---|
2276 | |
---|
2277 | (defvar singular-help-response-pending nil |
---|
2278 | "If non-nil, Singulars response has not been completely received. |
---|
2279 | |
---|
2280 | This variable is buffer-local.") |
---|
2281 | |
---|
2282 | (defvar singular-help-topic nil |
---|
2283 | "If non-nil, contains help topic to dhow in post output filter. |
---|
2284 | |
---|
2285 | This variable is buffer-local.") |
---|
2286 | |
---|
2287 | (defconst singular-help-command-regexp "^\\s-*shelp\\>" |
---|
2288 | "Regular expression to match Singular help commands.") |
---|
2289 | |
---|
2290 | (defconst singular-help-response-line-1 |
---|
2291 | "^Your help command could not be executed. Use\n" |
---|
2292 | "Regular expression that matches the first line of Singulars response.") |
---|
2293 | |
---|
2294 | (defconst singular-help-response-line-2 |
---|
2295 | "^C-h C-s \\(.*\\)\n") |
---|
2296 | |
---|
2297 | (defconst singular-help-response-line-3 |
---|
2298 | "^to enter the Singular online help\. For general\n" |
---|
2299 | "Regular expression that matches the first line of Singulars response.") |
---|
2300 | |
---|
2301 | (defconst singular-help-response-line-4 |
---|
2302 | "^information on Singular running on Emacs, type C-h m\.\n" |
---|
2303 | "Regular expression that matches the first line of Singulars response.") |
---|
2304 | |
---|
2305 | (defun singular-help-pre-input-filter (input) |
---|
2306 | "Check user's input for help commands. |
---|
2307 | Sets time stamp if one is found." |
---|
2308 | (if (string-match singular-help-command-regexp input) |
---|
2309 | (setq singular-help-time-stamp (cadr (current-time)))) |
---|
2310 | ;; return nil so that input passes unchanged |
---|
2311 | nil) |
---|
2312 | |
---|
2313 | (defun singular-help-pre-output-filter (output) |
---|
2314 | "Check for Singular's response on a help command. |
---|
2315 | Removes it and fires up `(info)' to handle the help command." |
---|
2316 | ;; check first |
---|
2317 | ;; - whether a help statement has been issued less than one second ago, or |
---|
2318 | ;; - whether there is a pending response. |
---|
2319 | ;; |
---|
2320 | ;; Only if one of these conditions is met we go on and check text for a |
---|
2321 | ;; response on a help command. Checking uncoditionally every piece of |
---|
2322 | ;; output would be far too expensive. |
---|
2323 | ;; |
---|
2324 | ;; If check fails nil is returned, what is exactly what we need for the |
---|
2325 | ;; filter. |
---|
2326 | (if (or (= (cadr (current-time)) singular-help-time-stamp) |
---|
2327 | singular-help-response-pending) |
---|
2328 | ;; if response is pending for more than five seconds, give up |
---|
2329 | (if (and singular-help-response-pending |
---|
2330 | (> (singular-time-stamp-difference (current-time) singular-help-time-stamp) 5)) |
---|
2331 | ;; this command returns nil, what is exactly what we need for the filter |
---|
2332 | (setq singular-help-response-pending nil) |
---|
2333 | ;; go through output, removing the response. If there is a |
---|
2334 | ;; pending response we nevertheless check for all lines, not only |
---|
2335 | ;; for the pending one. At last, pending responses should not |
---|
2336 | ;; occur to often. |
---|
2337 | (when (string-match singular-help-response-line-1 output) |
---|
2338 | (setq output (replace-match "" t t output)) |
---|
2339 | (setq singular-help-response-pending t)) |
---|
2340 | (when (string-match singular-help-response-line-2 output) |
---|
2341 | ;; after all, we found what we are looking for |
---|
2342 | (setq singular-help-topic (substring output (match-beginning 1) (match-end 1))) |
---|
2343 | (setq output (replace-match "" t t output)) |
---|
2344 | (setq singular-help-response-pending t)) |
---|
2345 | (when (string-match singular-help-response-line-3 output) |
---|
2346 | (setq output (replace-match "" t t output)) |
---|
2347 | (setq singular-help-response-pending t)) |
---|
2348 | (when (string-match singular-help-response-line-4 output) |
---|
2349 | (setq output (replace-match "" t t output)) |
---|
2350 | ;; we completely removed the help from output! |
---|
2351 | (setq singular-help-response-pending nil)) |
---|
2352 | |
---|
2353 | ;; return modified OUTPUT |
---|
2354 | output))) |
---|
2355 | |
---|
2356 | (defun singular-help-post-output-filter (&rest ignore) |
---|
2357 | (when singular-help-topic |
---|
2358 | (save-excursion (singular-help singular-help-topic)) |
---|
2359 | (setq singular-help-topic nil))) |
---|
2360 | |
---|
2361 | (defun singular-help (&optional help-topic) |
---|
2362 | "Show help on HELP-TOPIC in Singular online manual." |
---|
2363 | |
---|
2364 | (interactive "s") |
---|
2365 | |
---|
2366 | ;; check for empty help topic and convert it to top node |
---|
2367 | (if (or (null help-topic) (string= help-topic "")) |
---|
2368 | (setq help-topic "Top")) |
---|
2369 | |
---|
2370 | (let ((same-window-buffer-names |
---|
2371 | (cond |
---|
2372 | ((null singular-help-same-window) |
---|
2373 | nil) |
---|
2374 | ((eq singular-help-same-window 'default) |
---|
2375 | same-window-buffer-names) |
---|
2376 | (t |
---|
2377 | '("*info*")))) |
---|
2378 | (node-name (concat "(" (or singular-help-explicit-file-name |
---|
2379 | singular-help-file-name) |
---|
2380 | ")" help-topic))) |
---|
2381 | (pop-to-buffer "*info*") |
---|
2382 | (Info-goto-node node-name))) |
---|
2383 | |
---|
2384 | |
---|
2385 | (defun singular-help-init () |
---|
2386 | "Initialize online help support for Singular interactive mode. |
---|
2387 | |
---|
2388 | This function is called at mode initialization time." |
---|
2389 | (make-local-variable 'singular-help-time-stamp) |
---|
2390 | (make-local-variable 'singular-help-response-pending) |
---|
2391 | (make-local-variable 'singular-help-topic) |
---|
2392 | (add-hook 'singular-pre-input-filter-functions 'singular-help-pre-input-filter) |
---|
2393 | (add-hook 'singular-pre-output-filter-functions 'singular-help-pre-output-filter) |
---|
2394 | (add-hook 'singular-post-output-filter-functions 'singular-help-post-output-filter)) |
---|
2395 | ;;}}} |
---|
2396 | |
---|
2397 | ;;{{{ Debugging filters |
---|
2398 | (defun singular-debug-pre-input-filter (string) |
---|
2399 | "Display STRING and some markers in mini-buffer." |
---|
2400 | (singular-debug 'interactive-filter |
---|
2401 | (message "Pre-input filter: %s (li %S ci %S lo %S co %S)" |
---|
2402 | (singular-debug-format string) |
---|
2403 | (marker-position singular-last-input-section-start) |
---|
2404 | (marker-position singular-current-input-section-start) |
---|
2405 | (marker-position singular-last-output-section-start) |
---|
2406 | (marker-position singular-current-output-section-start))) |
---|
2407 | nil) |
---|
2408 | |
---|
2409 | (defun singular-debug-post-input-filter (beg end) |
---|
2410 | "Display BEG, END, and some markers in mini-buffer." |
---|
2411 | (singular-debug 'interactive-filter |
---|
2412 | (message "Post-input filter: (beg %S end %S) (li %S ci %S lo %S co %S)" |
---|
2413 | beg end |
---|
2414 | (marker-position singular-last-input-section-start) |
---|
2415 | (marker-position singular-current-input-section-start) |
---|
2416 | (marker-position singular-last-output-section-start) |
---|
2417 | (marker-position singular-current-output-section-start)))) |
---|
2418 | |
---|
2419 | (defun singular-debug-pre-output-filter (string) |
---|
2420 | "Display STRING and some markers in mini-buffer." |
---|
2421 | (singular-debug 'interactive-filter |
---|
2422 | (message "Pre-output filter: %s (li %S ci %S lo %S co %S)" |
---|
2423 | (singular-debug-format string) |
---|
2424 | (marker-position singular-last-input-section-start) |
---|
2425 | (marker-position singular-current-input-section-start) |
---|
2426 | (marker-position singular-last-output-section-start) |
---|
2427 | (marker-position singular-current-output-section-start))) |
---|
2428 | nil) |
---|
2429 | |
---|
2430 | (defun singular-debug-post-output-filter (beg end simple-sec-start) |
---|
2431 | "Display BEG, END, SIMPLE-SEC-START, and some markers in mini-buffer." |
---|
2432 | (singular-debug 'interactive-filter |
---|
2433 | (message "Post-output filter: (beg %S end %S sss %S) (li %S ci %S lo %S co %S)" |
---|
2434 | beg end simple-sec-start |
---|
2435 | (marker-position singular-last-input-section-start) |
---|
2436 | (marker-position singular-current-input-section-start) |
---|
2437 | (marker-position singular-last-output-section-start) |
---|
2438 | (marker-position singular-current-output-section-start)))) |
---|
2439 | |
---|
2440 | (defun singular-debug-filter-init () |
---|
2441 | "Add debug filters to the necessary hooks. |
---|
2442 | |
---|
2443 | This function is called at mode initialization time." |
---|
2444 | (add-hook 'singular-pre-input-filter-functions |
---|
2445 | 'singular-debug-pre-input-filter nil t) |
---|
2446 | (add-hook 'singular-post-input-filter-functions |
---|
2447 | 'singular-debug-post-input-filter nil t) |
---|
2448 | (add-hook 'singular-pre-output-filter-functions |
---|
2449 | 'singular-debug-pre-output-filter nil t) |
---|
2450 | (add-hook 'singular-post-output-filter-functions |
---|
2451 | 'singular-debug-post-output-filter nil t)) |
---|
2452 | ;;}}} |
---|
2453 | |
---|
2454 | ;;{{{ Demo mode |
---|
2455 | (defcustom singular-demo-chunk-regexp "\\(\n\\s *\n\\)" |
---|
2456 | "Regular expressions to recognize separate chunks of a demo file. |
---|
2457 | If there is a subexpression specified its contents is removed when the |
---|
2458 | chunk is displayed. |
---|
2459 | The default value is \"\\\\(\\n\\\\s *\\n\\\\)\" which means that chunks are |
---|
2460 | separated by a blank line which is removed when the chunks are displayed." |
---|
2461 | :type 'regexp |
---|
2462 | :group 'singular-demo-mode) |
---|
2463 | |
---|
2464 | (defcustom singular-demo-insert-into-history nil |
---|
2465 | "If non-nil, insert input into history even while demo mode is on. |
---|
2466 | Otherwise, demo chunks and other commands executed during demo mode are not |
---|
2467 | inserted into the history." |
---|
2468 | :type 'boolean |
---|
2469 | :group 'singular-demo-mode) |
---|
2470 | |
---|
2471 | (defcustom singular-demo-print-messages nil |
---|
2472 | "If non-nil, print message on how to continue demo mode." |
---|
2473 | :type 'boolean |
---|
2474 | :group 'singular-demo-mode) |
---|
2475 | |
---|
2476 | (defcustom singular-demo-exit-on-load nil |
---|
2477 | "If non-nil, a running demo is automatically discarded when a new one is loaded. |
---|
2478 | Otherwise, the load is aborted with an error." |
---|
2479 | :type 'boolean |
---|
2480 | :group 'singular-demo-mode) |
---|
2481 | |
---|
2482 | (defcustom singular-demo-load-directory nil |
---|
2483 | "Directory where demo files reside. |
---|
2484 | If non-nil, this directory is offered as a starting point to search for |
---|
2485 | demo files when `singular-demo-load' is called interactively. |
---|
2486 | If this variable equals nil whatever Emacs offers is used as starting |
---|
2487 | point. In general, this is the directory where Singular has been started |
---|
2488 | in." |
---|
2489 | :type '(choice (const nil) (file)) |
---|
2490 | :group 'singular-demo-mode) |
---|
2491 | |
---|
2492 | (defvar singular-demo-mode nil |
---|
2493 | "Non-nil if Singular demo mode is on. |
---|
2494 | |
---|
2495 | This variable is buffer-local.") |
---|
2496 | |
---|
2497 | (defvar singular-demo-old-mode-name nil |
---|
2498 | "Used to store previous `mode-name' before switching to demo mode. |
---|
2499 | |
---|
2500 | This variable is buffer-local.") |
---|
2501 | |
---|
2502 | (defvar singular-demo-end nil |
---|
2503 | "Marker pointing to end of demo file. |
---|
2504 | |
---|
2505 | This variable is buffer-local.") |
---|
2506 | |
---|
2507 | (defun singular-demo-load (demo-file) |
---|
2508 | "Load demo file DEMO-FILE and enter Singular demo mode. |
---|
2509 | NOT READY." |
---|
2510 | (interactive |
---|
2511 | (list |
---|
2512 | (cond |
---|
2513 | ;; Emacs |
---|
2514 | ((eq singular-emacs-flavor 'emacs) |
---|
2515 | (read-file-name "Load demo file: " |
---|
2516 | singular-demo-load-directory |
---|
2517 | nil t)) |
---|
2518 | ;; XEmacs |
---|
2519 | (t |
---|
2520 | ;; there are some problems with the window being popped up when this |
---|
2521 | ;; function is called from a menu. It does not display the contents |
---|
2522 | ;; of `singular-demo-load-directory' but of `default-directory'. |
---|
2523 | (let ((default-directory (or singular-demo-load-directory |
---|
2524 | default-directory))) |
---|
2525 | (read-file-name "Load demo file: " |
---|
2526 | singular-demo-load-directory |
---|
2527 | nil t)))))) |
---|
2528 | |
---|
2529 | ;; check for running demo |
---|
2530 | (if singular-demo-mode |
---|
2531 | (if singular-demo-exit-on-load |
---|
2532 | ;; silently exit running demo |
---|
2533 | (singular-demo-exit) |
---|
2534 | (error "There already is a demo running, exit with `singular-demo-exit' first"))) |
---|
2535 | |
---|
2536 | ;; load new demo |
---|
2537 | (let ((old-point-min (point-min))) |
---|
2538 | (unwind-protect |
---|
2539 | (progn |
---|
2540 | (goto-char (point-max)) |
---|
2541 | (widen) |
---|
2542 | (cond |
---|
2543 | ;; XEmacs |
---|
2544 | ((eq singular-emacs-flavor 'xemacs) |
---|
2545 | ;; load file and remember its end |
---|
2546 | (set-marker singular-demo-end |
---|
2547 | (+ (point) (nth 1 (insert-file-contents-literally demo-file))))) |
---|
2548 | ;; Emacs |
---|
2549 | (t |
---|
2550 | ;; Emacs does something like an `insert-before-markers' so |
---|
2551 | ;; save all essential markers |
---|
2552 | (let ((pmark-pos (marker-position (singular-process-mark))) |
---|
2553 | (sliss-pos (marker-position singular-last-input-section-start)) |
---|
2554 | (sciss-pos (marker-position singular-current-input-section-start)) |
---|
2555 | (sloss-pos (marker-position singular-last-output-section-start)) |
---|
2556 | (scoss-pos (marker-position singular-current-output-section-start))) |
---|
2557 | |
---|
2558 | (unwind-protect |
---|
2559 | ;; load file and remember its end |
---|
2560 | (set-marker singular-demo-end |
---|
2561 | (+ (point) (nth 1 (insert-file-contents-literally demo-file)))) |
---|
2562 | |
---|
2563 | ;; restore markers. |
---|
2564 | ;; This is unwind-protected. |
---|
2565 | (set-marker (singular-process-mark) pmark-pos) |
---|
2566 | (set-marker singular-last-input-section-start sliss-pos) |
---|
2567 | (set-marker singular-current-input-section-start sciss-pos) |
---|
2568 | (set-marker singular-last-output-section-start sloss-pos) |
---|
2569 | (set-marker singular-current-output-section-start scoss-pos)))))) |
---|
2570 | |
---|
2571 | ;; completely hide demo file. |
---|
2572 | ;; This is unwind-protected. |
---|
2573 | (narrow-to-region old-point-min (point)))) |
---|
2574 | |
---|
2575 | ;; switch demo mode on |
---|
2576 | (setq singular-demo-old-mode-name mode-name |
---|
2577 | mode-name "Singular Demo" |
---|
2578 | singular-demo-mode t) |
---|
2579 | (run-hooks 'singular-demo-mode-enter-hook) |
---|
2580 | (if singular-demo-print-messages (message "Hit RET to start demo")) |
---|
2581 | (force-mode-line-update)) |
---|
2582 | |
---|
2583 | (defun singular-demo-exit-internal () |
---|
2584 | "Exit Singular demo mode. |
---|
2585 | Recovers the old mode name, sets `singular-demo-mode' to nil, runs |
---|
2586 | the hooks on `singular-demo-mode-exit-hook'." |
---|
2587 | (setq mode-name singular-demo-old-mode-name |
---|
2588 | singular-demo-mode nil) |
---|
2589 | (run-hooks 'singular-demo-mode-exit-hook) |
---|
2590 | (force-mode-line-update)) |
---|
2591 | |
---|
2592 | (defun singular-demo-exit () |
---|
2593 | "Prematurely exit Singular demo mode. |
---|
2594 | Cleans up everything that is left from the demo. |
---|
2595 | Runs the hooks on `singular-demo-mode-exit-hook'. |
---|
2596 | Does nothing when Singular demo mode is turned off." |
---|
2597 | (interactive) |
---|
2598 | (when singular-demo-mode |
---|
2599 | ;; clean up hidden rest of demo file |
---|
2600 | (let ((old-point-min (point-min)) |
---|
2601 | (old-point-max (point-max))) |
---|
2602 | (unwind-protect |
---|
2603 | (progn |
---|
2604 | (widen) |
---|
2605 | (delete-region old-point-max singular-demo-end)) |
---|
2606 | ;; this is unwind-protected |
---|
2607 | (narrow-to-region old-point-min old-point-max))) |
---|
2608 | (singular-demo-exit-internal))) |
---|
2609 | |
---|
2610 | (defun singular-demo-show-next-chunk () |
---|
2611 | "Show next chunk of demo file at input prompt. |
---|
2612 | Assumes that Singular demo mode is on. |
---|
2613 | Moves point to end of buffer and widenes the buffer such that the next |
---|
2614 | chunk of the demo file becomes visible. |
---|
2615 | Finds and removes chunk separators as specified by |
---|
2616 | `singular-demo-chunk-regexp'. |
---|
2617 | Leaves demo mode after showing last chunk. In that case runs hooks on |
---|
2618 | `singular-demo-mode-exit-hook'." |
---|
2619 | (let ((old-point-min (point-min))) |
---|
2620 | (unwind-protect |
---|
2621 | (progn |
---|
2622 | (goto-char (point-max)) |
---|
2623 | (widen) |
---|
2624 | (if (re-search-forward singular-demo-chunk-regexp singular-demo-end 'limit) |
---|
2625 | (if (match-beginning 1) |
---|
2626 | (delete-region (match-beginning 1) (match-end 1))) |
---|
2627 | ;; remove trailing white-space. We may not use |
---|
2628 | ;; `(skip-syntax-backward "-")' since newline is has no white |
---|
2629 | ;; space syntax. The solution down below should suffice in |
---|
2630 | ;; almost all cases ... |
---|
2631 | (skip-chars-backward " \t\n\r") |
---|
2632 | (delete-region (point) singular-demo-end) |
---|
2633 | (singular-demo-exit-internal))) |
---|
2634 | |
---|
2635 | ;; this is unwind-protected |
---|
2636 | (narrow-to-region old-point-min (point))))) |
---|
2637 | |
---|
2638 | (defun singular-demo-mode-init () |
---|
2639 | "Initialize variables belonging to Singular demo mode. |
---|
2640 | Creates some buffer-local variables and the buffer-local marker |
---|
2641 | `singular-demo-end'. |
---|
2642 | |
---|
2643 | This function is called at mode initialization time." |
---|
2644 | (make-local-variable 'singular-demo-mode) |
---|
2645 | (make-local-variable 'singular-demo-mode-old-name) |
---|
2646 | (make-local-variable 'singular-demo-mode-end) |
---|
2647 | (if (not (and (boundp 'singular-demo-end) |
---|
2648 | singular-demo-end)) |
---|
2649 | (setq singular-demo-end (make-marker)))) |
---|
2650 | ;;}}} |
---|
2651 | |
---|
2652 | ;;{{{ Some lengthy notes on input and output |
---|
2653 | |
---|
2654 | ;; NOT READY[so sorry]! |
---|
2655 | |
---|
2656 | ;;}}} |
---|
2657 | |
---|
2658 | ;;{{{ Last input and output section |
---|
2659 | (defun singular-last-input-section (&optional no-error) |
---|
2660 | "Return last input section. |
---|
2661 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
2662 | last input section defined, throws an error otherwise." |
---|
2663 | (let ((last-input-start (marker-position singular-last-input-section-start)) |
---|
2664 | (last-input-end (marker-position singular-current-output-section-start))) |
---|
2665 | (cond ((and last-input-start last-input-end) |
---|
2666 | (singular-section-create (singular-simple-sec-at last-input-start) 'input |
---|
2667 | last-input-start last-input-end)) |
---|
2668 | (no-error nil) |
---|
2669 | (t (error "No last input section defined"))))) |
---|
2670 | |
---|
2671 | (defun singular-current-output-section (&optional no-error) |
---|
2672 | "Return current output section. |
---|
2673 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
2674 | current output section defined, throws an error otherwise." |
---|
2675 | (let ((current-output-start (marker-position singular-current-output-section-start)) |
---|
2676 | (current-output-end (save-excursion |
---|
2677 | (save-restriction |
---|
2678 | (widen) |
---|
2679 | (goto-char (singular-process-mark)) |
---|
2680 | (singular-skip-prompt-backward) |
---|
2681 | (and (bolp) (point)))))) |
---|
2682 | (cond ((and current-output-start current-output-end) |
---|
2683 | (singular-section-create (singular-simple-sec-at current-output-start) 'output |
---|
2684 | current-output-start current-output-end)) |
---|
2685 | (no-error nil) |
---|
2686 | (t (error "No current output section defined"))))) |
---|
2687 | |
---|
2688 | (defun singular-last-output-section (&optional no-error) |
---|
2689 | "Return last output section. |
---|
2690 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
2691 | last output section defined, throws an error otherwise." |
---|
2692 | (let ((last-output-start (marker-position singular-last-output-section-start)) |
---|
2693 | (last-output-end (marker-position singular-last-input-section-start))) |
---|
2694 | (cond ((and last-output-start last-output-end) |
---|
2695 | (singular-section-create (singular-simple-sec-at last-output-start) 'output |
---|
2696 | last-output-start last-output-end)) |
---|
2697 | (no-error nil) |
---|
2698 | (t (error "No last output section defined"))))) |
---|
2699 | |
---|
2700 | (defun singular-latest-output-section (&optional no-error) |
---|
2701 | "Return latest output section. |
---|
2702 | This is the current output section if it is defined, otherwise the |
---|
2703 | last output section. |
---|
2704 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
2705 | latest output section defined, throws an error otherwise." |
---|
2706 | (or (singular-current-output-section t) |
---|
2707 | (singular-last-output-section t) |
---|
2708 | (if no-error |
---|
2709 | nil |
---|
2710 | (error "No latest output section defined")))) |
---|
2711 | ;;}}} |
---|
2712 | |
---|
2713 | ;;{{{ Sending input |
---|
2714 | (defvar singular-pre-input-filter-functions nil |
---|
2715 | "Functions to call before input is sent to process. |
---|
2716 | These functions get one argument, a string containing the text which |
---|
2717 | is to be sent to process. The functions should return either nil |
---|
2718 | or a string. In the latter case the returned string replaces the |
---|
2719 | string to be sent to process. |
---|
2720 | |
---|
2721 | This is a buffer-local variable, not a buffer-local hook! |
---|
2722 | |
---|
2723 | `singular-run-hook-with-arg-and-value' is used to run the functions in |
---|
2724 | the list.") |
---|
2725 | |
---|
2726 | (defvar singular-post-input-filter-functions nil |
---|
2727 | "Functions to call after input is sent to process. |
---|
2728 | These functions get two arguments BEG and END. |
---|
2729 | If `singular-input-filter' has been called with a string as argument |
---|
2730 | BEG and END gives the position of this string after insertion into the |
---|
2731 | buffer. |
---|
2732 | If `singular-input-filter' has been called with a position as argument |
---|
2733 | BEG and END equal process mark and that position, resp. |
---|
2734 | The functions may assume that no narrowing is in effect and may change |
---|
2735 | point at will. |
---|
2736 | |
---|
2737 | This hook is buffer-local.") |
---|
2738 | |
---|
2739 | (defvar singular-current-input-section-start nil |
---|
2740 | "Marker to the start of the current input section. |
---|
2741 | This marker points nowhere on startup or if there is no current input |
---|
2742 | section. |
---|
2743 | |
---|
2744 | This variable is buffer-local.") |
---|
2745 | |
---|
2746 | (defvar singular-last-input-section-start nil |
---|
2747 | "Marker to the start of the last input section. |
---|
2748 | This marker points nowhere on startup. |
---|
2749 | |
---|
2750 | This variable is buffer-local.") |
---|
2751 | |
---|
2752 | (defun singular-input-filter-init (pos) |
---|
2753 | "Initialize all variables concerning input. |
---|
2754 | POS is the position of the process mark." |
---|
2755 | ;; localize variables not yet localized in `singular-interactive-mode' |
---|
2756 | (make-local-variable 'singular-current-input-section-start) |
---|
2757 | (make-local-variable 'singular-last-input-section-start) |
---|
2758 | |
---|
2759 | ;; initialize markers |
---|
2760 | (if (not (markerp singular-current-input-section-start)) |
---|
2761 | (setq singular-current-input-section-start (make-marker))) |
---|
2762 | (if (not (markerp singular-last-input-section-start)) |
---|
2763 | (setq singular-last-input-section-start (make-marker)))) |
---|
2764 | |
---|
2765 | (defun singular-send-string (process string) |
---|
2766 | "Send newline terminated STRING to to process PROCESS. |
---|
2767 | Runs the hooks on `singular-pre-input-filter-functions' in the buffer |
---|
2768 | associated to PROCESS. The functions get the non-terminated string." |
---|
2769 | (let ((process-buffer (process-buffer process))) |
---|
2770 | |
---|
2771 | ;; check whether buffer is still alive |
---|
2772 | (if (and process-buffer (buffer-name process-buffer)) |
---|
2773 | (save-excursion |
---|
2774 | (set-buffer process-buffer) |
---|
2775 | (send-string |
---|
2776 | process |
---|
2777 | (concat (singular-run-hook-with-arg-and-value |
---|
2778 | singular-pre-input-filter-functions string) |
---|
2779 | "\n")))))) |
---|
2780 | |
---|
2781 | (defun singular-input-filter (process string-or-pos) |
---|
2782 | "Insert/update input from user in buffer associated to PROCESS. |
---|
2783 | Inserts STRING-OR-POS followed by a newline at process mark if it is a |
---|
2784 | string. |
---|
2785 | Assumes that the input is already inserted and that it is placed |
---|
2786 | between process mark and STRING-OR-POS if the latter is a position. |
---|
2787 | Inserts a newline after STRING-OR-POS. |
---|
2788 | |
---|
2789 | Takes care off: |
---|
2790 | - current buffer as well as point and restriction in buffer associated |
---|
2791 | with process, even against non-local exits. |
---|
2792 | Updates: |
---|
2793 | - process mark; |
---|
2794 | - current and last sections; |
---|
2795 | - simple sections; |
---|
2796 | - mode line. |
---|
2797 | |
---|
2798 | Runs the hooks on `singular-pre-input-filter-functions' and |
---|
2799 | `singular-post-input-filter-functions'. |
---|
2800 | |
---|
2801 | For a more detailed descriptions of the input filter, the markers it |
---|
2802 | sets, and input filter functions refer to the section \"Some lengthy |
---|
2803 | notes on input and output\" in singular.el." |
---|
2804 | (let ((process-buffer (process-buffer process))) |
---|
2805 | |
---|
2806 | ;; check whether buffer is still alive |
---|
2807 | (if (and process-buffer (buffer-name process-buffer)) |
---|
2808 | (let ((old-buffer (current-buffer)) |
---|
2809 | (old-pmark (marker-position (process-mark process))) |
---|
2810 | old-point old-point-min old-point-max) |
---|
2811 | (unwind-protect |
---|
2812 | (let (simple-sec-start) |
---|
2813 | (set-buffer process-buffer) |
---|
2814 | ;; the following lines are not protected since the |
---|
2815 | ;; unwind-forms refer the variables being set here |
---|
2816 | (setq old-point (point-marker) |
---|
2817 | old-point-min (point-min-marker) |
---|
2818 | old-point-max (point-max-marker) |
---|
2819 | |
---|
2820 | ;; get end of last simple section (equals start of |
---|
2821 | ;; current) |
---|
2822 | simple-sec-start (singular-simple-sec-last-end-position)) |
---|
2823 | |
---|
2824 | ;; prepare for insertion |
---|
2825 | (widen) |
---|
2826 | (set-marker-insertion-type old-point t) |
---|
2827 | (set-marker-insertion-type old-point-max t) |
---|
2828 | |
---|
2829 | ;; insert string at process mark and advance process |
---|
2830 | ;; mark after insertion. If it not a string simply |
---|
2831 | ;; jump to desired position and insrt a newline. |
---|
2832 | (if (stringp string-or-pos) |
---|
2833 | (progn |
---|
2834 | (goto-char old-pmark) |
---|
2835 | (insert string-or-pos)) |
---|
2836 | (goto-char string-or-pos)) |
---|
2837 | (insert ?\n) |
---|
2838 | (set-marker (process-mark process) (point)) |
---|
2839 | |
---|
2840 | ;; create new simple section and update section markers |
---|
2841 | (cond |
---|
2842 | ((eq (singular-simple-sec-create 'input (point)) 'empty) |
---|
2843 | nil) |
---|
2844 | ;; a new simple section has been created ... |
---|
2845 | ((null (marker-position singular-current-input-section-start)) |
---|
2846 | ;; ... and even a new input section has been created! |
---|
2847 | (set-marker singular-current-input-section-start |
---|
2848 | simple-sec-start) |
---|
2849 | (set-marker singular-last-output-section-start |
---|
2850 | singular-current-output-section-start) |
---|
2851 | (set-marker singular-current-output-section-start nil))) |
---|
2852 | |
---|
2853 | ;; run post-output hooks and force mode-line update |
---|
2854 | (run-hook-with-args 'singular-post-input-filter-functions |
---|
2855 | old-pmark (point))) |
---|
2856 | |
---|
2857 | ;; restore buffer, restrictions and point |
---|
2858 | (narrow-to-region old-point-min old-point-max) |
---|
2859 | (set-marker old-point-min nil) |
---|
2860 | (set-marker old-point-max nil) |
---|
2861 | (goto-char old-point) |
---|
2862 | (set-marker old-point nil) |
---|
2863 | (set-buffer old-buffer)))))) |
---|
2864 | |
---|
2865 | (defun singular-get-old-input (get-section) |
---|
2866 | "Retrieve old input. |
---|
2867 | Retrivies from beginning of current section to point if GET-SECTION is |
---|
2868 | non-nil, otherwise on a per-line base." |
---|
2869 | (if get-section |
---|
2870 | ;; get input from input section |
---|
2871 | (let ((section (singular-section-at (point)))) |
---|
2872 | (if (eq (singular-section-type section) 'input) |
---|
2873 | (setq old-input (singular-input-section-to-string section (point))) |
---|
2874 | (error "Not on an input section"))) |
---|
2875 | ;; get input from line |
---|
2876 | (save-excursion |
---|
2877 | (beginning-of-line) |
---|
2878 | (singular-prompt-skip-forward) |
---|
2879 | (let ((old-point (point))) |
---|
2880 | (end-of-line) |
---|
2881 | (buffer-substring old-point (point)))))) |
---|
2882 | |
---|
2883 | (defun singular-send-or-copy-input (send-full-section) |
---|
2884 | "Send input from current buffer to associated process. |
---|
2885 | NOT READY[old input copying, demo mode, |
---|
2886 | eol-on-send, history, SEND-FULL-SECTION]!" |
---|
2887 | (interactive "P") |
---|
2888 | |
---|
2889 | (let ((process (get-buffer-process (current-buffer))) |
---|
2890 | pmark) |
---|
2891 | ;; some checks and initializations |
---|
2892 | (or process (error "Current buffer has no process")) |
---|
2893 | (setq pmark (marker-position (process-mark process))) |
---|
2894 | |
---|
2895 | (cond |
---|
2896 | (;; check for demo mode and show next chunk if necessary |
---|
2897 | (and singular-demo-mode |
---|
2898 | (eq (point) pmark) |
---|
2899 | (eq pmark (point-max))) |
---|
2900 | (singular-demo-show-next-chunk)) |
---|
2901 | |
---|
2902 | (;; get old input |
---|
2903 | (< (point) pmark) |
---|
2904 | (let ((old-input (singular-get-old-input send-full-section))) |
---|
2905 | (goto-char pmark) |
---|
2906 | (insert old-input))) |
---|
2907 | |
---|
2908 | (;; send input from pmark to point after doing history expansion |
---|
2909 | t |
---|
2910 | ;; I don't know if this is the right point to insert the message |
---|
2911 | ;; print message if demo mode is active |
---|
2912 | (and singular-demo-mode |
---|
2913 | singular-demo-print-messages |
---|
2914 | (message "Hit RET to continue demo")) |
---|
2915 | |
---|
2916 | ;; go to desired position. NOT READY. |
---|
2917 | ;(if singular-eol-on-send (end-of-line)) |
---|
2918 | ;(if send-full-section (goto-char (point-max))) |
---|
2919 | |
---|
2920 | (let* ((input (buffer-substring pmark (point)))) |
---|
2921 | ;; insert string into history |
---|
2922 | (singular-history-insert input) |
---|
2923 | ;; send string to process |
---|
2924 | (singular-send-string process input) |
---|
2925 | ;; "insert" it into buffer |
---|
2926 | (singular-input-filter process (point))))))) |
---|
2927 | ;;}}} |
---|
2928 | |
---|
2929 | ;;{{{ Receiving output |
---|
2930 | (defvar singular-pre-output-filter-functions nil |
---|
2931 | "Functions to call before output is inserted into the buffer. |
---|
2932 | These functions get one argument, a string containing the text sent |
---|
2933 | from process. The functions should return either nil or a string. |
---|
2934 | In the latter case the returned string replaces the string sent from |
---|
2935 | process. |
---|
2936 | |
---|
2937 | This is a buffer-local variable, not a buffer-local hook! |
---|
2938 | |
---|
2939 | `singular-run-hook-with-arg-and-value' is used to run the functions in |
---|
2940 | this list.") |
---|
2941 | |
---|
2942 | (defvar singular-post-output-filter-functions nil |
---|
2943 | "Functions to call after output is inserted into the buffer. |
---|
2944 | These functions get three arguments BEG, END, and SIMPLE-SEC-START. |
---|
2945 | The region between BEG and END is what has been inserted into the |
---|
2946 | buffer. |
---|
2947 | SIMPLE-SEC-START is the start of the simple section which has been |
---|
2948 | created on insertion or nil if no simple section has been created. |
---|
2949 | The functions may assume that no narrowing is in effect and may change |
---|
2950 | point at will. |
---|
2951 | |
---|
2952 | This hook is buffer-local.") |
---|
2953 | |
---|
2954 | (defvar singular-current-output-section-start nil |
---|
2955 | "Marker to the start of the current output section. |
---|
2956 | This marker points nowhere on startup or if there is no current output |
---|
2957 | section. |
---|
2958 | |
---|
2959 | This variable is buffer-local.") |
---|
2960 | |
---|
2961 | (defvar singular-last-output-section-start nil |
---|
2962 | "Marker to the start of the last output section. |
---|
2963 | This marker points nowhere on startup. |
---|
2964 | |
---|
2965 | This variable is buffer-local.") |
---|
2966 | |
---|
2967 | (defun singular-output-filter-init (pos) |
---|
2968 | "Initialize all variables concerning output including process mark. |
---|
2969 | Set process mark to POS." |
---|
2970 | |
---|
2971 | ;; localize variables not yet localized in `singular-interactive-mode' |
---|
2972 | (make-local-variable 'singular-current-output-section-start) |
---|
2973 | (make-local-variable 'singular-last-output-section-start) |
---|
2974 | |
---|
2975 | ;; initialize markers |
---|
2976 | (if (not (markerp singular-current-output-section-start)) |
---|
2977 | (setq singular-current-output-section-start (make-marker))) |
---|
2978 | (if (not (markerp singular-last-output-section-start)) |
---|
2979 | (setq singular-last-output-section-start (make-marker))) |
---|
2980 | (set-marker (singular-process-mark) pos)) |
---|
2981 | |
---|
2982 | (defun singular-output-filter (process string) |
---|
2983 | "Insert STRING containing output from PROCESS into its associated buffer. |
---|
2984 | Takes care off: |
---|
2985 | - current buffer as well as point and restriction in buffer associated |
---|
2986 | with process, even against non-local exits. |
---|
2987 | Updates: |
---|
2988 | - process mark; |
---|
2989 | - current and last sections; |
---|
2990 | - simple sections; |
---|
2991 | - mode line. |
---|
2992 | Runs the hooks on `singular-pre-output-filter-functions' and |
---|
2993 | `singular-post-output-filter-functions'. |
---|
2994 | |
---|
2995 | For a more detailed descriptions of the output filter, the markers it |
---|
2996 | sets, and output filter functions refer to the section \"Some lengthy |
---|
2997 | notes on input and output\" in singular.el." |
---|
2998 | (let ((process-buffer (process-buffer process))) |
---|
2999 | |
---|
3000 | ;; check whether buffer is still alive |
---|
3001 | (if (and process-buffer (buffer-name process-buffer)) |
---|
3002 | (let ((old-buffer (current-buffer)) |
---|
3003 | (old-pmark (marker-position (process-mark process))) |
---|
3004 | old-point old-point-min old-point-max) |
---|
3005 | (unwind-protect |
---|
3006 | (let (simple-sec-start) |
---|
3007 | (set-buffer process-buffer) |
---|
3008 | ;; the following lines are not protected since the |
---|
3009 | ;; unwind-forms refer the variables being set here |
---|
3010 | (setq old-point (point-marker) |
---|
3011 | old-point-min (point-min-marker) |
---|
3012 | old-point-max (point-max-marker) |
---|
3013 | |
---|
3014 | ;; get end of last simple section (equals start of |
---|
3015 | ;; current) |
---|
3016 | simple-sec-start (singular-simple-sec-last-end-position) |
---|
3017 | |
---|
3018 | ;; get string to insert |
---|
3019 | string (singular-run-hook-with-arg-and-value |
---|
3020 | singular-pre-output-filter-functions |
---|
3021 | string)) |
---|
3022 | |
---|
3023 | ;; prepare for insertion |
---|
3024 | (widen) |
---|
3025 | (set-marker-insertion-type old-point t) |
---|
3026 | (set-marker-insertion-type old-point-max t) |
---|
3027 | |
---|
3028 | ;; insert string at process mark and advance process |
---|
3029 | ;; mark after insertion |
---|
3030 | (goto-char old-pmark) |
---|
3031 | (insert string) |
---|
3032 | (set-marker (process-mark process) (point)) |
---|
3033 | |
---|
3034 | ;; create new simple section and update section markers |
---|
3035 | (cond |
---|
3036 | ((eq (singular-simple-sec-create 'output (point)) 'empty) |
---|
3037 | (setq simple-sec-start nil)) |
---|
3038 | ;; a new simple section has been created ... |
---|
3039 | ((null (marker-position singular-current-output-section-start)) |
---|
3040 | ;; ... and even a new output section has been created! |
---|
3041 | (set-marker singular-current-output-section-start |
---|
3042 | simple-sec-start) |
---|
3043 | (set-marker singular-last-input-section-start |
---|
3044 | singular-current-input-section-start) |
---|
3045 | (set-marker singular-current-input-section-start nil))) |
---|
3046 | |
---|
3047 | ;; run post-output hooks and force mode-line update |
---|
3048 | (run-hook-with-args 'singular-post-output-filter-functions |
---|
3049 | old-pmark (point) simple-sec-start) |
---|
3050 | (force-mode-line-update)) |
---|
3051 | |
---|
3052 | ;; restore buffer, restrictions and point |
---|
3053 | (narrow-to-region old-point-min old-point-max) |
---|
3054 | (set-marker old-point-min nil) |
---|
3055 | (set-marker old-point-max nil) |
---|
3056 | (goto-char old-point) |
---|
3057 | (set-marker old-point nil) |
---|
3058 | (set-buffer old-buffer)))))) |
---|
3059 | ;;}}} |
---|
3060 | |
---|
3061 | ;;{{{ Singular interactive mode |
---|
3062 | (defun singular-interactive-mode () |
---|
3063 | "Major mode for interacting with Singular. |
---|
3064 | |
---|
3065 | NOT READY [how to send input]! |
---|
3066 | |
---|
3067 | NOT READY [multiple Singulars]! |
---|
3068 | |
---|
3069 | \\{singular-interactive-mode-map} |
---|
3070 | Customization: Entry to this mode runs the hooks on `comint-mode-hook' |
---|
3071 | and `singular-interactive-mode-hook' \(in that order). |
---|
3072 | |
---|
3073 | NOT READY [much more to come. See shell.el.]!" |
---|
3074 | (interactive) |
---|
3075 | |
---|
3076 | ;; uh-oh, we have to set `comint-input-ring-size' before we call |
---|
3077 | ;; `comint-mode' |
---|
3078 | (singular-history-init) |
---|
3079 | |
---|
3080 | ;; run comint mode and do basic mode setup |
---|
3081 | (let (comint-mode-hook) |
---|
3082 | (comint-mode)) |
---|
3083 | (setq major-mode 'singular-interactive-mode) |
---|
3084 | (setq mode-name "Singular Interaction") |
---|
3085 | |
---|
3086 | ;; key bindings, syntax tables and menus |
---|
3087 | (singular-interactive-mode-map-init) |
---|
3088 | (singular-mode-syntax-table-init) |
---|
3089 | (singular-interactive-mode-menu-init) |
---|
3090 | |
---|
3091 | (setq comment-start "// ") |
---|
3092 | (setq comment-start-skip "// *") |
---|
3093 | (setq comment-end "") |
---|
3094 | |
---|
3095 | ; (singular-prompt-init) |
---|
3096 | |
---|
3097 | ;; initialize singular demo mode, input and output filters |
---|
3098 | (singular-demo-mode-init) |
---|
3099 | (make-local-variable 'singular-pre-input-filter-functions) |
---|
3100 | (make-local-hook 'singular-post-input-filter-functions) |
---|
3101 | (make-local-variable 'singular-pre-output-filter-functions) |
---|
3102 | (make-local-hook 'singular-post-output-filter-functions) |
---|
3103 | |
---|
3104 | ;; folding sections |
---|
3105 | (singular-folding-init) |
---|
3106 | |
---|
3107 | ;; debugging filters |
---|
3108 | (singular-debug 'interactive-filter (singular-debug-filter-init)) |
---|
3109 | |
---|
3110 | (singular-help-init) |
---|
3111 | |
---|
3112 | ;; other input or output filters |
---|
3113 | (add-hook 'singular-post-output-filter-functions |
---|
3114 | 'singular-remove-prompt-filter nil t) |
---|
3115 | |
---|
3116 | ;; Emacs Font Lock mode initialization |
---|
3117 | (cond |
---|
3118 | ;; Emacs |
---|
3119 | ((eq singular-emacs-flavor 'emacs) |
---|
3120 | (singular-interactive-font-lock-init))) |
---|
3121 | |
---|
3122 | (run-hooks 'singular-interactive-mode-hook)) |
---|
3123 | ;;}}} |
---|
3124 | |
---|
3125 | ;;{{{ Starting singular |
---|
3126 | (defvar singular-start-file "~/.emacs_singularrc" |
---|
3127 | "Name of start-up file to pass to Singular. |
---|
3128 | If the file named by this variable exists it is given as initial input |
---|
3129 | to any Singular process being started. Note that this may lose due to |
---|
3130 | a timing error if Singular discards input when it starts up.") |
---|
3131 | |
---|
3132 | (defvar singular-default-executable "Singular" |
---|
3133 | "Default name of Singular executable. |
---|
3134 | Used by `singular' when new Singular processes are started.") |
---|
3135 | |
---|
3136 | (defvar singular-default-name "singular" |
---|
3137 | "Default process name for Singular process. |
---|
3138 | Used by `singular' when new Singular processes are started.") |
---|
3139 | |
---|
3140 | (defvar singular-default-switches '("-t") |
---|
3141 | "Default switches for Singular processes. |
---|
3142 | Used by `singular' when new Singular processes are started.") |
---|
3143 | |
---|
3144 | (defun singular-exit-sentinel (process message) |
---|
3145 | "Clean up after termination of Singular. |
---|
3146 | Writes back input ring after regular termination of Singular if |
---|
3147 | process buffer is still alive." |
---|
3148 | (save-excursion |
---|
3149 | (singular-debug 'interactive |
---|
3150 | (message "Sentinel: %s" (substring message 0 -1))) |
---|
3151 | ;; exit demo mode if necessary |
---|
3152 | (singular-demo-exit) |
---|
3153 | (if (string-match "finished\\|exited" message) |
---|
3154 | (let ((process-buffer (process-buffer process))) |
---|
3155 | (if (and process-buffer |
---|
3156 | (buffer-name process-buffer) |
---|
3157 | (set-buffer process-buffer)) |
---|
3158 | ;; write back history |
---|
3159 | (singular-history-write)))))) |
---|
3160 | |
---|
3161 | (defun singular-exec (buffer name executable start-file switches) |
---|
3162 | "Start a new Singular process NAME in BUFFER, running EXECUTABLE. |
---|
3163 | EXECUTABLE should be a string denoting an executable program. |
---|
3164 | SWITCHES should be a list of strings that are passed as command line |
---|
3165 | switches. START-FILE should be the name of a file which contents is |
---|
3166 | sent to the process. |
---|
3167 | |
---|
3168 | Deletes any old processes running in that buffer. |
---|
3169 | Moves point to the end of BUFFER. |
---|
3170 | Initializes all important markers and the simple sections. |
---|
3171 | Runs the hooks on `singular-exec-hook'. |
---|
3172 | Returns BUFFER." |
---|
3173 | (let ((old-buffer (current-buffer))) |
---|
3174 | (unwind-protect |
---|
3175 | (progn |
---|
3176 | (set-buffer buffer) |
---|
3177 | |
---|
3178 | ;; delete any old processes |
---|
3179 | (let ((process (get-buffer-process buffer))) |
---|
3180 | (if process (delete-process process))) |
---|
3181 | |
---|
3182 | ;; create new process |
---|
3183 | (singular-debug 'interactive (message "Starting new Singular")) |
---|
3184 | (let ((process (comint-exec-1 name buffer executable switches))) |
---|
3185 | |
---|
3186 | ;; set process filter and sentinel |
---|
3187 | (set-process-filter process 'singular-output-filter) |
---|
3188 | (set-process-sentinel process 'singular-exit-sentinel) |
---|
3189 | (make-local-variable 'comint-ptyp) |
---|
3190 | (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. |
---|
3191 | |
---|
3192 | ;; go to the end of the buffer, initialize I/O and simple |
---|
3193 | ;; sections |
---|
3194 | (goto-char (point-max)) |
---|
3195 | (singular-input-filter-init (point)) |
---|
3196 | (singular-output-filter-init (point)) |
---|
3197 | (singular-simple-sec-init (point)) |
---|
3198 | |
---|
3199 | ;; feed process with start file and read input ring. Take |
---|
3200 | ;; care about the undo information. |
---|
3201 | (if start-file |
---|
3202 | (let ((buffer-undo-list t) start-string) |
---|
3203 | (singular-debug 'interactive (message "Feeding start file")) |
---|
3204 | (sleep-for 1) ; try to avoid timing errors |
---|
3205 | (insert-file-contents start-file) |
---|
3206 | (setq start-string (buffer-substring (point) (point-max))) |
---|
3207 | (delete-region (point) (point-max)) |
---|
3208 | (send-string process start-string))) |
---|
3209 | |
---|
3210 | ;; read history if present |
---|
3211 | (singular-history-read) |
---|
3212 | |
---|
3213 | ;; execute hooks |
---|
3214 | (run-hooks 'singular-exec-hook)) |
---|
3215 | |
---|
3216 | buffer) |
---|
3217 | ;; this code is unwide-protected |
---|
3218 | (set-buffer old-buffer)))) |
---|
3219 | |
---|
3220 | ;; Note: |
---|
3221 | ;; |
---|
3222 | ;; In contrast to shell.el, `singular' does not run |
---|
3223 | ;; `singular-interactive-mode' every time a new Singular process is |
---|
3224 | ;; started, but only when a new buffer is created. This behaviour seems |
---|
3225 | ;; more intuitive w.r.t. local variables and hooks. |
---|
3226 | |
---|
3227 | (defun singular (&optional executable name switches) |
---|
3228 | "Run an inferior Singular process, with I/O through an Emacs buffer. |
---|
3229 | |
---|
3230 | NOT READY [arguments, default values, and interactive use]! |
---|
3231 | |
---|
3232 | If buffer exists but Singular is not running, starts new Singular. |
---|
3233 | If buffer exists and Singular is running, just switches to buffer. |
---|
3234 | If a file `~/.emacs_singularrc' exists, it is given as initial input. |
---|
3235 | Note that this may lose due to a timing error if Singular discards |
---|
3236 | input when it starts up. |
---|
3237 | |
---|
3238 | If a new buffer is created it is put in Singular interactive mode, |
---|
3239 | giving commands for sending input and handling ouput of Singular. See |
---|
3240 | `singular-interactive-mode'. |
---|
3241 | |
---|
3242 | Every time `singular' starts a new Singular process it runs the hooks |
---|
3243 | on `singular-exec-hook'. |
---|
3244 | |
---|
3245 | Type \\[describe-mode] in the Singular buffer for a list of commands." |
---|
3246 | ;; handle interactive calls |
---|
3247 | (interactive (list singular-default-executable |
---|
3248 | singular-default-name |
---|
3249 | singular-default-switches)) |
---|
3250 | |
---|
3251 | (let* (;; get default values for optional arguments |
---|
3252 | (executable (or executable singular-default-executable)) |
---|
3253 | (name (or name singular-default-name)) |
---|
3254 | (switches (or switches singular-default-switches)) |
---|
3255 | |
---|
3256 | (buffer-name (singular-process-name-to-buffer-name name)) |
---|
3257 | ;; buffer associated with Singular, nil if there is none |
---|
3258 | (buffer (get-buffer buffer-name))) |
---|
3259 | |
---|
3260 | (if (not buffer) |
---|
3261 | (progn |
---|
3262 | ;; create new buffer and call `singular-interactive-mode' |
---|
3263 | (singular-debug 'interactive (message "Creating new buffer")) |
---|
3264 | (setq buffer (get-buffer-create buffer-name)) |
---|
3265 | (set-buffer buffer) |
---|
3266 | |
---|
3267 | (singular-debug 'interactive (message "Calling `singular-interactive-mode'")) |
---|
3268 | (singular-interactive-mode))) |
---|
3269 | |
---|
3270 | (if (not (comint-check-proc buffer)) |
---|
3271 | ;; create new process if there is none |
---|
3272 | (singular-exec buffer name executable |
---|
3273 | (if (file-exists-p singular-start-file) |
---|
3274 | singular-start-file) |
---|
3275 | switches)) |
---|
3276 | |
---|
3277 | ;; pop to buffer |
---|
3278 | (singular-debug 'interactive (message "Calling `pop-to-buffer'")) |
---|
3279 | (pop-to-buffer buffer t))) |
---|
3280 | |
---|
3281 | ;; for convenience only |
---|
3282 | (defalias 'Singular 'singular) |
---|
3283 | |
---|
3284 | (defun singular-generate-new-buffer-name (name) |
---|
3285 | "Generate a unique buffer name for a singular interactive buffer. |
---|
3286 | The string NAME is the desired name for the singular interactive |
---|
3287 | buffer, without surrounding stars. |
---|
3288 | The string returned is surrounded by stars. |
---|
3289 | |
---|
3290 | If no buffer with name \"*NAME*\" exists, return \"*NAME*\". |
---|
3291 | Otherwise check for buffer called \"*NAME<n>*\" where n is a |
---|
3292 | increasing number and return \"*NAME<n>*\" if no such buffer |
---|
3293 | exists." |
---|
3294 | (let ((new-name (singular-process-name-to-buffer-name name)) |
---|
3295 | (count 2)) |
---|
3296 | (while (get-buffer new-name) |
---|
3297 | (setq new-name (singular-process-name-to-buffer-name |
---|
3298 | (concat name "<" (format "%d" count) ">"))) |
---|
3299 | (setq count (1+ count))) |
---|
3300 | new-name)) |
---|
3301 | |
---|
3302 | (defun singular-other (file) |
---|
3303 | "Start a new Singular, different to the default Singular. |
---|
3304 | FILE is a Singular executable. |
---|
3305 | |
---|
3306 | Asks in the minibuffer for a buffer-name and for Singular options. |
---|
3307 | Calls `singular' with the appropriate arguments." |
---|
3308 | (interactive "fSingular executable: ") |
---|
3309 | ;; NOT READY [code] |
---|
3310 | (let ((name (singular-generate-new-buffer-name |
---|
3311 | (downcase (file-name-nondirectory file)))) |
---|
3312 | (switches "") |
---|
3313 | temp) |
---|
3314 | |
---|
3315 | ;; Read buffer name from minibuffer at strip surrounding stars |
---|
3316 | ;; NOT READY: This code is not very beautyful. |
---|
3317 | (let ((buffer-exists t) |
---|
3318 | (new-name name)) |
---|
3319 | (while buffer-exists |
---|
3320 | (setq new-name (read-from-minibuffer "Singular buffer name: " name)) |
---|
3321 | (if (get-buffer new-name) |
---|
3322 | (progn |
---|
3323 | (message "This buffer already exists.") |
---|
3324 | (sleep-for 1)) |
---|
3325 | (setq buffer-exists nil) |
---|
3326 | (setq name new-name)))) |
---|
3327 | |
---|
3328 | |
---|
3329 | (if (string-match "^\\*\\(.*\\)\\*$" name) |
---|
3330 | (setq name (substring name (match-beginning 1) (match-end 1)))) |
---|
3331 | |
---|
3332 | ;; make one string of options from list of default options |
---|
3333 | (setq temp singular-default-switches) |
---|
3334 | (while temp |
---|
3335 | (setq switches (concat switches (car temp) " ")) |
---|
3336 | (setq temp (cdr temp))) |
---|
3337 | ;; in minibuffer omit display of option "-t " |
---|
3338 | (setq switches (read-from-minibuffer "Singular options: " |
---|
3339 | (replace-in-string switches "-t " ""))) |
---|
3340 | |
---|
3341 | ;; make list of strings of switch-string |
---|
3342 | (setq temp '("-t")) |
---|
3343 | (while (string-match "-[^ ]*" switches) |
---|
3344 | (setq temp (append temp (list (substring switches (match-beginning 0) |
---|
3345 | (match-end 0))))) |
---|
3346 | (setq switches (substring switches (match-end 0) nil))) |
---|
3347 | (setq switches temp) |
---|
3348 | |
---|
3349 | (singular file name switches))) |
---|
3350 | ;;}}} |
---|
3351 | ;;}}} |
---|
3352 | |
---|
3353 | (provide 'singular) |
---|
3354 | |
---|
3355 | ;;; Local Variables: |
---|
3356 | ;;; fill-column: 75 |
---|
3357 | ;;; End: |
---|
3358 | |
---|
3359 | ;;; singular.el ends here. |
---|