1 | ;;; singular.el --- Emacs support for Computer Algebra System Singular |
---|
2 | |
---|
3 | ;; $Id: singular.el,v 1.26 1998-08-14 06:57:23 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 | ;; - use a `fill-column' of 70 for doc strings and comments |
---|
18 | ;; - use foldings to structure the source code but try not to exceed a |
---|
19 | ;; maximal depth of two folding (one folding in another folding which is |
---|
20 | ;; on top-level) |
---|
21 | ;; - use lowercase folding titles except for first word |
---|
22 | ;; - folding-marks are `;;{{{' and `;;}}}' resp., for sake of standard |
---|
23 | ;; conformity |
---|
24 | ;; - mark incomplete doc strings or code with `NOT READY' (optionally |
---|
25 | ;; followed by an explanation what exactly is missing) |
---|
26 | ;; - documentation on the customization of the modes is in the |
---|
27 | ;; doc-strings to `singular-mode-configuration' and |
---|
28 | ;; `singular-interactive-mode-configuration', resp. |
---|
29 | ;; |
---|
30 | ;; - use `singular' as prefix for all global symbols |
---|
31 | ;; - use `singular-debug' as prefix for all global symbols concerning |
---|
32 | ;; debugging. |
---|
33 | ;; |
---|
34 | ;; - mark dependencies on Emacs flavor/version with a comment of the form |
---|
35 | ;; `;; Emacs[ <version>]' resp. |
---|
36 | ;; `;; XEmacs[ <version>][ <nasty comment>]' (in that order, if |
---|
37 | ;; possible) |
---|
38 | ;; - use a `cond' statement to execute Emacs flavor/version-dependent code, |
---|
39 | ;; not `if'. This is to make such checks more extensible. |
---|
40 | ;; - try to define different functions for different flavors/version |
---|
41 | ;; and use `singular-fset' at library-loading time to set the function |
---|
42 | ;; you really need. If the function is named `singular-<basename>', the |
---|
43 | ;; flavor/version-dependent functions should be named |
---|
44 | ;; `singular-<flavor>[-<version>]-<basename>'. |
---|
45 | |
---|
46 | ;; - use `singular-debug' for debugging output/actions |
---|
47 | ;; - to switch between buffer and process names, use the functions |
---|
48 | ;; `singular-process-name-to-buffer-name' and |
---|
49 | ;; `singular-buffer-name-to-process-name' |
---|
50 | ;; - we assume that the buffer is *not* read-only |
---|
51 | |
---|
52 | ;;}}} |
---|
53 | |
---|
54 | (require 'comint) |
---|
55 | |
---|
56 | ;;{{{ Code common to both modes |
---|
57 | ;;{{{ Debugging stuff |
---|
58 | (defvar singular-debug nil |
---|
59 | "*List of modes to debug or t to debug all modes. |
---|
60 | Currently, there are the modes `interactive', `interactive-filter', |
---|
61 | `interactive-simple-secs', and `interactive-sections'.") |
---|
62 | |
---|
63 | (defun singular-debug-format (string) |
---|
64 | "Return STRING in a nicer format." |
---|
65 | (save-match-data |
---|
66 | (while (string-match "\n" string) |
---|
67 | (setq string (replace-match "^J" nil nil string))) |
---|
68 | |
---|
69 | (if (> (length string) 16) |
---|
70 | (concat "<" (substring string 0 7) ">...<" (substring string -8) ">") |
---|
71 | (concat "<" string ">")))) |
---|
72 | |
---|
73 | (defmacro singular-debug (mode form &optional else-form) |
---|
74 | "Major debugging hook for singular.el. |
---|
75 | Evaluates FORM if `singular-debug' equals t or if MODE is an element |
---|
76 | of `singular-debug', othwerwise ELSE-FORM." |
---|
77 | `(if (or (eq singular-debug t) |
---|
78 | (memq ,mode singular-debug)) |
---|
79 | ,form |
---|
80 | ,else-form)) |
---|
81 | ;;}}} |
---|
82 | |
---|
83 | ;;{{{ Determining version |
---|
84 | (defvar singular-emacs-flavor nil |
---|
85 | "A symbol describing the current Emacs. |
---|
86 | Currently, only Emacs \(`emacs') and XEmacs are supported \(`xemacs').") |
---|
87 | |
---|
88 | (defvar singular-emacs-major-version nil |
---|
89 | "An integer describing the major version of the current emacs.") |
---|
90 | |
---|
91 | (defvar singular-emacs-minor-version nil |
---|
92 | "An integer describing the major version of the current emacs.") |
---|
93 | |
---|
94 | (defun singular-fset (real-function emacs-function xemacs-function |
---|
95 | &optional emacs-19-function) |
---|
96 | "Set REAL-FUNCTION to one of the functions, in dependency on Emacs flavor and version. |
---|
97 | Sets REAL-FUNCTION to XEMACS-FUNCTION if `singular-emacs-flavor' is |
---|
98 | `xemacs'. Sets REAL-FUNCTION to EMACS-FUNCTION if `singular-emacs-flavor' |
---|
99 | is `emacs' and `singular-emacs-major-version' is 20. Otherwise, sets |
---|
100 | REAL-FUNCTION to EMACS-19-FUNCTION which defaults to EMACS-FUNCTION. |
---|
101 | |
---|
102 | This is not as common as would be desirable. But it is sufficient so far." |
---|
103 | (cond |
---|
104 | ;; XEmacs |
---|
105 | ((eq singular-emacs-flavor 'xemacs) |
---|
106 | (fset real-function xemacs-function)) |
---|
107 | ;; Emacs 20 |
---|
108 | ((eq singular-emacs-major-version 20) |
---|
109 | (fset real-function emacs-function)) |
---|
110 | ;; Emacs 19 |
---|
111 | (t |
---|
112 | (fset real-function (or emacs-19-function emacs-function))))) |
---|
113 | |
---|
114 | (defun singular-set-version () |
---|
115 | "Determine flavor, major version, and minor version of current emacs. |
---|
116 | singular.el is guaranteed to run on Emacs 19.34, Emacs 20.2, and XEmacs |
---|
117 | 20.2. It should run on newer version and on slightly older ones, too." |
---|
118 | |
---|
119 | ;; get major and minor versions first |
---|
120 | (if (and (boundp 'emacs-major-version) |
---|
121 | (boundp 'emacs-minor-version)) |
---|
122 | (setq singular-emacs-major-version emacs-major-version |
---|
123 | singular-emacs-minor-version emacs-minor-version) |
---|
124 | (with-output-to-temp-buffer "*singular warnings*" |
---|
125 | (princ |
---|
126 | "You seem to have quite an old Emacs or XEmacs version. Some of the |
---|
127 | features from singular.el will not work properly. Consider upgrading to a |
---|
128 | more recent version of Emacs or XEmacs. singular.el is guaranteed to run |
---|
129 | on Emacs 19.34, Emacs 20.2, and XEmacs 20.2.")) |
---|
130 | ;; assume the oldest version we support |
---|
131 | (setq singular-emacs-major-version 19 |
---|
132 | singular-emacs-minor-version 34)) |
---|
133 | |
---|
134 | ;; get flavor |
---|
135 | (if (string-match "XEmacs\\|Lucid" emacs-version) |
---|
136 | (setq singular-emacs-flavor 'xemacs) |
---|
137 | (setq singular-emacs-flavor 'emacs))) |
---|
138 | |
---|
139 | (singular-set-version) |
---|
140 | ;;}}} |
---|
141 | |
---|
142 | ;;{{{ Faces |
---|
143 | |
---|
144 | ;; Note: |
---|
145 | ;; |
---|
146 | ;; These fonts look quite good: |
---|
147 | ;; "-adobe-courier-bold-r-*-*-18-*-*-*-*-*-*-*" for input |
---|
148 | ;; "-adobe-courier-bold-o-*-*-18-*-*-*-*-*-*-*" for output |
---|
149 | ;; |
---|
150 | ;; For my (Jens) Emacs a quite good variant is: |
---|
151 | ;; "-misc-fixed-bold-*-*-*-15-*-*-*-*-*-*-*" for input |
---|
152 | ;; "-misc-fixed-medium-*-*-*-15-*-*-*-*-*-*-*" for output |
---|
153 | |
---|
154 | (make-face 'singular-input-face) |
---|
155 | ;(set-face-background 'singular-input-face "Orange") |
---|
156 | (defvar singular-input-face 'singular-input-face |
---|
157 | "Face for user input. |
---|
158 | This face should have set background only.") |
---|
159 | |
---|
160 | (make-face 'singular-output-face) |
---|
161 | ;(set-face-font 'singular-output-face "-adobe-courier-bold-o-*-*-18-*-*-*-*-*-*-*") |
---|
162 | ;(set-face-background 'singular-output-face "Wheat") |
---|
163 | (defvar singular-output-face 'singular-output-face |
---|
164 | "Face for Singular output. |
---|
165 | This face should have set background only.") |
---|
166 | |
---|
167 | (defun singular-lookup-face (face-type) |
---|
168 | "Return face belonging to FACE-TYPE. |
---|
169 | NOT READY [should be rewritten completely. Interface should stay the same.]!" |
---|
170 | (cond ((eq face-type 'input) singular-input-face) |
---|
171 | ((eq face-type 'output) singular-output-face))) |
---|
172 | |
---|
173 | ;; Additional faces for font locking |
---|
174 | (make-face 'font-lock-singular-error-face) |
---|
175 | |
---|
176 | (defvar font-lock-singular-error-face 'font-lock-singular-error-face |
---|
177 | "Additional font-lock face for singular errors.") |
---|
178 | |
---|
179 | (cond |
---|
180 | ;; XEmacs |
---|
181 | ((eq singular-emacs-flavor 'xemacs) |
---|
182 | ;; That 'append avoids to overwrite the face if it is already set |
---|
183 | (set-face-foreground 'font-lock-singular-error-face "Red" |
---|
184 | 'global nil 'append))) |
---|
185 | |
---|
186 | (make-face 'font-lock-singular-warn-face) |
---|
187 | |
---|
188 | (defvar font-lock-singular-warn-face 'font-lock-singular-warn-face |
---|
189 | "Additional font-lock face for singular warnings.") |
---|
190 | |
---|
191 | (cond |
---|
192 | ;; XEmacs |
---|
193 | ((eq singular-emacs-flavor 'xemacs) |
---|
194 | ;; That 'append avoids to overwrite the face if it is already set |
---|
195 | (set-face-foreground 'font-lock-singular-warn-face "Orange" |
---|
196 | 'global nil 'append))) |
---|
197 | |
---|
198 | (make-face 'font-lock-singular-prompt-face) |
---|
199 | |
---|
200 | (defvar font-lock-singular-warn-face 'font-lock-singular-prompt-face |
---|
201 | "Addition font-lock face for the singular prompt.") |
---|
202 | |
---|
203 | (cond |
---|
204 | ;; XEmacs |
---|
205 | ((eq singular-emacs-flavor 'xemacs) |
---|
206 | ;; That 'append avoids to overwrite the face if it is already set |
---|
207 | (set-face-foreground 'font-lock-singular-prompt-face "Gray50" |
---|
208 | 'global nil 'append))) |
---|
209 | ;;}}} |
---|
210 | |
---|
211 | ;;{{{ Font-locking |
---|
212 | ;(make-regexp '("def" "ideal" "int" "intmat" "intvec" |
---|
213 | ; "link" "list" "map" "matrix" "module" |
---|
214 | ; "number" "poly" "proc" "qring" "resolution" |
---|
215 | ; "ring" "string" "vector")) |
---|
216 | |
---|
217 | (defvar singular-font-lock-keywords-1 |
---|
218 | '( |
---|
219 | ("\\<def\\|i\\(deal\\|nt\\(\\|mat\\|vec\\)\\)\\|li\\(nk\\|st\\)\\|m\\(a\\(p\\|trix\\)\\|odule\\)\\|number\\|p\\(oly\\|roc\\)\\|qring\\|r\\(esolution\\|ing\\)\\|string\\|vector\\>" . font-lock-type-face) |
---|
220 | ("^\\(> \\|. \\)" . font-lock-singular-prompt-face) |
---|
221 | ("^ [\\?].*" 0 font-lock-singular-error-face t) |
---|
222 | ("^// \\(\\*\\*.*\\)" 1 font-lock-singular-warn-face t) |
---|
223 | ) |
---|
224 | "Subdued level for highlighting in singular-(interactive)-mode") |
---|
225 | |
---|
226 | (defvar singular-font-lock-keywords-2 |
---|
227 | (append |
---|
228 | singular-font-lock-keywords-1 |
---|
229 | '( |
---|
230 | ("^ [\\?].*`\\(\\sw\\sw+\\)`" 1 font-lock-reference-name-face t) |
---|
231 | ;; ())) |
---|
232 | )) |
---|
233 | "Gaudy level for highlihgting in singular-(interactive)-mode") |
---|
234 | |
---|
235 | (defvar singular-font-lock-keywords singular-font-lock-keywords-1 |
---|
236 | "Default highlighting for singular-(interactive)-mode") |
---|
237 | |
---|
238 | (defvar singular-font-lock-defaults |
---|
239 | '((singular-font-lock-keywords |
---|
240 | singular-font-lock-keywords-1 |
---|
241 | singular-font-lock-keywords-2) |
---|
242 | nil ;; KEYWORDS-ONLY |
---|
243 | nil ;; CASE-FOLD (ignore case when non-nil) |
---|
244 | ((?_ . "w")) ;; SYNTAX-ALIST |
---|
245 | (beginning-of-line)) ;; SYNTAX_BEGIN |
---|
246 | "Emacs-default for font-lock-mode in singular-(interactive)-mode") |
---|
247 | |
---|
248 | (cond |
---|
249 | ;; XEmacs |
---|
250 | ((eq singular-emacs-flavor 'xemacs) |
---|
251 | (singular-debug 'interactive (message "setting up font-lock for XEmacs")) |
---|
252 | (put 'singular-interactive-mode 'font-lock-defaults |
---|
253 | singular-font-lock-defaults))) |
---|
254 | ;;}}} |
---|
255 | ;;}}} |
---|
256 | |
---|
257 | ;;{{{ Singular interactive mode |
---|
258 | ;;{{{ Key map and menus |
---|
259 | (defvar singular-interactive-mode-map () |
---|
260 | "Key map to use in Singular interactive mode.") |
---|
261 | |
---|
262 | (if singular-interactive-mode-map |
---|
263 | () |
---|
264 | (cond |
---|
265 | ;; Emacs |
---|
266 | ((eq singular-emacs-flavor 'emacs) |
---|
267 | (setq singular-interactive-mode-map |
---|
268 | (nconc (make-sparse-keymap) comint-mode-map))) |
---|
269 | ;; XEmacs |
---|
270 | (t |
---|
271 | (setq singular-interactive-mode-map (make-keymap)) |
---|
272 | (set-keymap-parents singular-interactive-mode-map (list comint-mode-map)) |
---|
273 | (set-keymap-name singular-interactive-mode-map |
---|
274 | 'singular-interactive-mode-map))) |
---|
275 | (define-key singular-interactive-mode-map "\C-m" 'singular-send-or-copy-input) |
---|
276 | (define-key singular-interactive-mode-map "\C-c\C-f" 'singular-load-file) |
---|
277 | (define-key singular-interactive-mode-map "\C-c\C-l" 'singular-load-library) |
---|
278 | (define-key singular-interactive-mode-map "\C-c\C-d" 'singular-demo-load) |
---|
279 | (define-key singular-interactive-mode-map "\C-c\C-t" 'singular-toggle-truncate-lines) |
---|
280 | (define-key singular-interactive-mode-map "\C-c$" 'singular-exit-singular) |
---|
281 | (define-key singular-interactive-mode-map "\C-cfl" 'singular-fold-last-output) |
---|
282 | (define-key singular-interactive-mode-map "\C-cfa" 'singular-fold-all-output) |
---|
283 | (define-key singular-interactive-mode-map "\C-cfp" 'singular-fold-at-point) |
---|
284 | (define-key singular-interactive-mode-map "\C-cul" 'singular-unfold-last-output) |
---|
285 | (define-key singular-interactive-mode-map "\C-cua" 'singular-unfold-all-output) |
---|
286 | (define-key singular-interactive-mode-map "\C-cup" 'singular-unfold-at-point)) |
---|
287 | |
---|
288 | (defvar singular-interactive-mode-menu-1 nil |
---|
289 | "NOT READY [docu]") |
---|
290 | |
---|
291 | (defvar singular-interactive-mode-menu-2 nil |
---|
292 | "NOT READY [docu]") |
---|
293 | |
---|
294 | (defvar singular-start-menu-definition |
---|
295 | '("Singular" |
---|
296 | ["start default" singular t] |
---|
297 | ["start..." singular-other t] |
---|
298 | ["exit" singular-exit-singular t]) |
---|
299 | "NOT READY [docu]") |
---|
300 | |
---|
301 | (if singular-interactive-mode-menu-1 |
---|
302 | () |
---|
303 | (cond |
---|
304 | ;; XEmacs |
---|
305 | ((eq singular-emacs-flavor 'xemacs) |
---|
306 | (easy-menu-define |
---|
307 | singular-interactive-mode-menu-1 |
---|
308 | singular-interactive-mode-map "" |
---|
309 | singular-start-menu-definition)))) |
---|
310 | |
---|
311 | (if singular-interactive-mode-menu-2 |
---|
312 | () |
---|
313 | (cond |
---|
314 | ;; XEmacs |
---|
315 | ((eq singular-emacs-flavor 'xemacs) |
---|
316 | (easy-menu-define |
---|
317 | singular-interactive-mode-menu-2 |
---|
318 | singular-interactive-mode-map "" |
---|
319 | '("Commands" |
---|
320 | ["load file..." singular-load-file t] |
---|
321 | ("load library" |
---|
322 | ["all.lib" (singular-load-library "all.lib" t) t] |
---|
323 | ["classify.lib" (singular-load-library "classify.lib" t) t] |
---|
324 | ["deform.lib" (singular-load-library "deform.lib" t) t] |
---|
325 | ["elim.lib" (singular-load-library "elim.lib" t) t] |
---|
326 | ["finvar.lib" (singular-load-library "finvar.lib" t) t] |
---|
327 | ["general.lib" (singular-load-library "general.lib" t) t] |
---|
328 | ["graphics.lib" (singular-load-library "graphics.lib" t) t] |
---|
329 | ["hnoether.lib" (singular-load-library "hnoether.lib" t) t] |
---|
330 | ["homolog.lib" (singular-load-library "homolog.lib" t) t] |
---|
331 | ["inout.lib" (singular-load-library "inout.lib" t) t] |
---|
332 | ["invar.lib" (singular-load-library "invar.lib" t) t] |
---|
333 | ["latex.lib" (singular-load-library "latex.lib" t) t] |
---|
334 | ["matrix.lib" (singular-load-library "matrix.lib" t) t] |
---|
335 | ["normal.lib" (singular-load-library "normal.lib" t) t] |
---|
336 | ["poly.lib" (singular-load-library "poly.lib" t) t] |
---|
337 | ["presolve.lib" (singular-load-library "presolve.lib" t) t] |
---|
338 | ["primdec.lib" (singular-load-library "primdec.lib" t) t] |
---|
339 | ["primitiv.lib" (singular-load-library "primitiv.lib" t) t] |
---|
340 | ["random.lib" (singular-load-library "random.lib" t) t] |
---|
341 | ["ring.lib" (singular-load-library "ring.lib" t) t] |
---|
342 | ["sing.lib" (singular-load-library "sing.lib" t) t] |
---|
343 | ["standard.lib" (singular-load-library "standard.lib" t) t] |
---|
344 | "---" |
---|
345 | ["other..." singular-load-library t]) |
---|
346 | "---" |
---|
347 | ["load demo" singular-demo-load (not singular-demo-mode)] |
---|
348 | ["exit demo" singular-demo-exit singular-demo-mode] |
---|
349 | "---" |
---|
350 | ["truncate lines" singular-toggle-truncate-lines |
---|
351 | :style toggle :selected truncate-lines] |
---|
352 | "---" |
---|
353 | ["fold last output" singular-fold-last-output t] |
---|
354 | ["fold all output" singular-fold-all-output t] |
---|
355 | ["fold at point" singular-fold-at-point t] |
---|
356 | "---" |
---|
357 | ["unfold last output" singular-unfold-last-output t] |
---|
358 | ["unfold all output" singular-unfold-all-output t] |
---|
359 | ["unfold at point" singular-unfold-at-point t] |
---|
360 | ))))) |
---|
361 | |
---|
362 | ;; NOT READY |
---|
363 | ;; This is just a temporary hack for XEmacs demo. |
---|
364 | (defvar singular-install-in-main-menu nil |
---|
365 | "NOT READY [docu]") |
---|
366 | |
---|
367 | (if singular-install-in-main-menu |
---|
368 | (cond |
---|
369 | ;; XEmacs |
---|
370 | ((eq singular-emacs-flavor 'xemacs) |
---|
371 | (add-submenu nil |
---|
372 | singular-start-menu-definition)))) |
---|
373 | |
---|
374 | ;;{{{ Syntax table |
---|
375 | (defvar singular-interactive-mode-syntax-table nil |
---|
376 | "Syntax table for singular-interactive-mode") |
---|
377 | |
---|
378 | (if singular-interactive-mode-syntax-table |
---|
379 | () |
---|
380 | (setq singular-interactive-mode-syntax-table (make-syntax-table)) |
---|
381 | ;; rest taken from cc-mode.el |
---|
382 | (modify-syntax-entry ?_ "_" singular-interactive-mode-syntax-table) |
---|
383 | (modify-syntax-entry ?\\ "\\" singular-interactive-mode-syntax-table) |
---|
384 | (modify-syntax-entry ?+ "." singular-interactive-mode-syntax-table) |
---|
385 | (modify-syntax-entry ?- "." singular-interactive-mode-syntax-table) |
---|
386 | (modify-syntax-entry ?= "." singular-interactive-mode-syntax-table) |
---|
387 | (modify-syntax-entry ?% "." singular-interactive-mode-syntax-table) |
---|
388 | (modify-syntax-entry ?< "." singular-interactive-mode-syntax-table) |
---|
389 | (modify-syntax-entry ?> "." singular-interactive-mode-syntax-table) |
---|
390 | (modify-syntax-entry ?& "." singular-interactive-mode-syntax-table) |
---|
391 | (modify-syntax-entry ?| "." singular-interactive-mode-syntax-table) |
---|
392 | (modify-syntax-entry ?\' "\"" singular-interactive-mode-syntax-table) |
---|
393 | (cond |
---|
394 | ;; Emacs |
---|
395 | ((eq singular-emacs-flavor 'emacs) |
---|
396 | (modify-syntax-entry ?/ ". 124b" singular-interactive-mode-syntax-table)) |
---|
397 | ;; XEmacs |
---|
398 | (t |
---|
399 | (modify-syntax-entry ?/ ". 1456" singular-interactive-mode-syntax-table))) |
---|
400 | (modify-syntax-entry ?* ". 23" singular-interactive-mode-syntax-table) |
---|
401 | (modify-syntax-entry ?\n "> b" singular-interactive-mode-syntax-table) |
---|
402 | (modify-syntax-entry ?\^m "> b" singular-interactive-mode-syntax-table)) |
---|
403 | |
---|
404 | ;;}}} |
---|
405 | |
---|
406 | ;;{{{ Miscellaneous |
---|
407 | |
---|
408 | ;; Note: |
---|
409 | ;; |
---|
410 | ;; We assume a one-to-one correspondance between Singular buffers |
---|
411 | ;; and Singular processes. We always have |
---|
412 | ;; (equal buffer-name (concat "*" process-name "*")). |
---|
413 | |
---|
414 | (defun singular-buffer-name-to-process-name (buffer-name) |
---|
415 | "Create the process name for BUFFER-NAME. |
---|
416 | The process name is the buffer name with surrounding `*' stripped |
---|
417 | off." |
---|
418 | (substring buffer-name 1 -1)) |
---|
419 | |
---|
420 | (defun singular-process-name-to-buffer-name (process-name) |
---|
421 | "Create the buffer name for PROCESS-NAME. |
---|
422 | The buffer name is the process name with surrounding `*'." |
---|
423 | (concat "*" process-name "*")) |
---|
424 | |
---|
425 | (defun singular-run-hook-with-arg-and-value (hook value) |
---|
426 | "Call functions on HOOK. |
---|
427 | Provides argument VALUE. If a function returns a non-nil value it |
---|
428 | replaces VALUE as new argument to the functions. Returns final |
---|
429 | VALUE." |
---|
430 | (let (result) |
---|
431 | (while hook |
---|
432 | (setq result (funcall (car hook) value)) |
---|
433 | (and result (setq value result)) |
---|
434 | (setq hook (cdr hook))) |
---|
435 | value)) |
---|
436 | |
---|
437 | (defmacro singular-process () |
---|
438 | "Return process of current buffer." |
---|
439 | (get-buffer-process (current-buffer))) |
---|
440 | |
---|
441 | (defmacro singular-process-mark () |
---|
442 | "Return process mark of current buffer." |
---|
443 | (process-mark (get-buffer-process (current-buffer)))) |
---|
444 | |
---|
445 | (defun singular-load-file (file &optional noexpand) |
---|
446 | "Read a file in Singular (via '< \"FILE\";'). |
---|
447 | If optional argument NOEXPAND is nil, FILE is expanded using |
---|
448 | `expand-file-name'." |
---|
449 | (interactive "fLoad file: ") |
---|
450 | (let* ((filename (if noexpand file (expand-file-name file))) |
---|
451 | (string (concat "< \"" filename "\";")) |
---|
452 | (process (singular-process))) |
---|
453 | (singular-input-filter process string) |
---|
454 | (singular-send-string process string))) |
---|
455 | |
---|
456 | (defun singular-load-library (file &optional noexpand) |
---|
457 | "Read a Singular library (via 'LIB \"FILE\";'). |
---|
458 | If optional argument NOEXPAND is nil, FILE is expanded using |
---|
459 | `expand-file-name'." |
---|
460 | (interactive "fLoad Library: ") |
---|
461 | (let* ((filename (if noexpand file (expand-file-name file))) |
---|
462 | (string (concat "LIB \"" filename "\";")) |
---|
463 | (process (singular-process))) |
---|
464 | (singular-input-filter process string) |
---|
465 | (singular-send-string process string))) |
---|
466 | |
---|
467 | (defun singular-exit-singular () |
---|
468 | "Exit Singular and kill Singular buffer. |
---|
469 | Sends string \"quit;\" to Singular process." |
---|
470 | (interactive) |
---|
471 | (let ((string "quit;") |
---|
472 | (process (singular-process))) |
---|
473 | (singular-input-filter process string) |
---|
474 | (singular-send-string process string)) |
---|
475 | (kill-buffer (current-buffer))) |
---|
476 | |
---|
477 | ;; The function `singular-toggle-truncate-lines' is obsolete in XEmacs |
---|
478 | ;; but not in Emacs. So define it anyway. |
---|
479 | (defun singular-toggle-truncate-lines () |
---|
480 | "Toggle truncate-lines." |
---|
481 | (interactive) |
---|
482 | (setq truncate-lines (not truncate-lines)) |
---|
483 | (recenter)) |
---|
484 | ;;}}} |
---|
485 | |
---|
486 | ;;{{{ Customizing variables of comint |
---|
487 | |
---|
488 | ;; Note: |
---|
489 | ;; |
---|
490 | ;; In contrast to the variables from comint.el, all the variables |
---|
491 | ;; below are global variables. It would not make any sense to make |
---|
492 | ;; them buffer-local since |
---|
493 | ;; o they are read only when Singular interactive mode comes up; |
---|
494 | ;; o since they are Singular-dependent and not user-dependent, i.e., |
---|
495 | ;; the user would not mind to change them. |
---|
496 | ;; |
---|
497 | ;; For the same reasons these variables are not marked as |
---|
498 | ;; "customizable" by a leading `*'. |
---|
499 | |
---|
500 | (defvar singular-prompt-regexp "^> " |
---|
501 | "Regexp to match prompt patterns in Singular. |
---|
502 | Should not match the continuation prompt \(`.'), only the regular |
---|
503 | prompt \(`>'). |
---|
504 | |
---|
505 | This variable is used to initialize `comint-prompt-regexp' when |
---|
506 | Singular interactive mode starts up.") |
---|
507 | |
---|
508 | (defvar singular-delimiter-argument-list '(?= ?\( ?\) ?, ?;) |
---|
509 | "List of characters to recognize as separate arguments. |
---|
510 | |
---|
511 | This variable is used to initialize `comint-delimiter-argument-list' |
---|
512 | when Singular interactive mode starts up.") |
---|
513 | |
---|
514 | (defvar singular-input-ignoredups t |
---|
515 | "If non-nil, don't add input matching the last on the input ring. |
---|
516 | |
---|
517 | This variable is used to initialize `comint-input-ignoredups' when |
---|
518 | Singular interactive mode starts up.") |
---|
519 | |
---|
520 | (defvar singular-buffer-maximum-size 2048 |
---|
521 | "The maximum size in lines for Singular buffers. |
---|
522 | |
---|
523 | This variable is used to initialize `comint-buffer-maximum-size' when |
---|
524 | Singular interactive mode starts up.") |
---|
525 | |
---|
526 | (defvar singular-input-ring-size 64 |
---|
527 | "Size of input history ring. |
---|
528 | |
---|
529 | This variable is used to initialize `comint-input-ring-size' when |
---|
530 | Singular interactive mode starts up.") |
---|
531 | |
---|
532 | (defvar singular-history-filter-regexp "\\`\\(..?\\|\\s *\\)\\'" |
---|
533 | "Regular expression to filter strings *not* to insert in the history. |
---|
534 | By default, input consisting of less than three characters and input |
---|
535 | consisting of white-space only is not added to the history.") |
---|
536 | |
---|
537 | (defvar singular-history-filter |
---|
538 | (function (lambda (string) |
---|
539 | (not (string-match singular-history-filter-regexp string)))) |
---|
540 | "Predicate for filtering additions to input history. |
---|
541 | |
---|
542 | This variable is used to initialize `comint-input-filter' when |
---|
543 | Singular interactive mode starts up.") |
---|
544 | ;;}}} |
---|
545 | |
---|
546 | ;;{{{ Skipping and stripping prompts and newlines and other things |
---|
547 | |
---|
548 | ;; Note: |
---|
549 | ;; |
---|
550 | ;; All of these functions modify the match data! |
---|
551 | |
---|
552 | (defun singular-strip-white-space (string &optional trailing leading) |
---|
553 | "Strip off trailing or leading white-space from STRING. |
---|
554 | Strips off trailing white-space if optional argument TRAILING is |
---|
555 | non-nil. |
---|
556 | Strips off leading white-space if optional argument LEADING is |
---|
557 | non-nil." |
---|
558 | (let ((beg 0) |
---|
559 | (end (length string))) |
---|
560 | (and leading |
---|
561 | (string-match "\\`\\s-*" string) |
---|
562 | (setq beg (match-end 0))) |
---|
563 | (and trailing |
---|
564 | (string-match "\\s-*\\'" string beg) |
---|
565 | (setq end (match-beginning 0))) |
---|
566 | (substring string beg end))) |
---|
567 | |
---|
568 | (defconst singular-extended-prompt-regexp "\\([?>.] \\)" |
---|
569 | "Matches one Singular prompt. |
---|
570 | Should not be anchored neither to start nor to end!") |
---|
571 | |
---|
572 | (defconst singular-strip-leading-prompt-regexp |
---|
573 | (concat "\\`" singular-extended-prompt-regexp "+") |
---|
574 | "Matches Singular prompt anchored to string start.") |
---|
575 | |
---|
576 | (defun singular-strip-leading-prompt (string) |
---|
577 | "Strip leading prompts from STRING. |
---|
578 | May or may not return STRING or a modified copy of it." |
---|
579 | (if (string-match singular-strip-leading-prompt-regexp string) |
---|
580 | (substring string (match-end 0)) |
---|
581 | string)) |
---|
582 | |
---|
583 | (defconst singular-remove-prompt-regexp |
---|
584 | (concat "^" singular-extended-prompt-regexp |
---|
585 | "*" singular-extended-prompt-regexp) |
---|
586 | "Matches a non-empty sequence of prompts at start of a line.") |
---|
587 | |
---|
588 | (defun singular-remove-prompt (beg end) |
---|
589 | "Remove all superfluous prompts from region between BEG and END. |
---|
590 | Removes all but the last prompt of a sequence if that sequence ends at |
---|
591 | END. |
---|
592 | The region between BEG and END should be accessible. |
---|
593 | Leaves point after the last prompt found." |
---|
594 | (let ((end (copy-marker end)) |
---|
595 | prompt-end) |
---|
596 | (goto-char beg) |
---|
597 | (while (and (setq prompt-end |
---|
598 | (re-search-forward singular-remove-prompt-regexp end t)) |
---|
599 | (not (= end prompt-end))) |
---|
600 | (delete-region (match-beginning 0) prompt-end)) |
---|
601 | |
---|
602 | ;; check for trailing prompt |
---|
603 | (if prompt-end |
---|
604 | (delete-region (match-beginning 0) (match-beginning 2))) |
---|
605 | (set-marker end nil))) |
---|
606 | |
---|
607 | (defconst singular-skip-prompt-forward-regexp |
---|
608 | (concat singular-extended-prompt-regexp "*") |
---|
609 | "Matches an arbitary sequence of Singular prompts.") |
---|
610 | |
---|
611 | (defun singular-skip-prompt-forward () |
---|
612 | "Skip forward over prompts." |
---|
613 | (looking-at singular-skip-prompt-forward-regexp) |
---|
614 | (goto-char (match-end 0))) |
---|
615 | |
---|
616 | (defun singular-skip-prompt-backward () |
---|
617 | "Skip backward over prompts." |
---|
618 | (while (re-search-backward singular-extended-prompt-regexp (- (point) 2) t))) |
---|
619 | ;;}}} |
---|
620 | |
---|
621 | ;;{{{ Simple section stuff for both Emacs and XEmacs |
---|
622 | |
---|
623 | ;; Note: |
---|
624 | ;; |
---|
625 | ;; Sections and simple sections are used to mark Singular's input and |
---|
626 | ;; output for further access. Here are some general notes on simple |
---|
627 | ;; sections. Sections are explained in the respective folding. |
---|
628 | ;; |
---|
629 | ;; In general, simple sections are more or less Emacs' overlays or XEmacs |
---|
630 | ;; extents, resp. But they are more than simply an interface to overlays |
---|
631 | ;; or sections. |
---|
632 | ;; |
---|
633 | ;; - Simple sections are non-empty portions of text. They are interpreted |
---|
634 | ;; as left-closed, right-opened intervals, i.e., the start point of a |
---|
635 | ;; simple sections belongs to it whereas the end point does not. |
---|
636 | ;; - Simple sections start and end at line borders only. |
---|
637 | ;; - Simple sections do not overlap. Thus, any point in the buffer may be |
---|
638 | ;; covered by at most one simple section. |
---|
639 | ;; - Besides from their start and their end, simple sections have some type |
---|
640 | ;; associated. |
---|
641 | ;; - Simple sections are realized using overlays (extents for XEmacs) |
---|
642 | ;; which define the start and, end, and type (via properties) of the |
---|
643 | ;; simple section. Actually, as a lisp object a simple section is |
---|
644 | ;; nothing else but the underlying overlay. |
---|
645 | ;; - There may be so-called clear simple sections. Clear simple sections |
---|
646 | ;; have not an underlying overlay. Instead, they start at the end of the |
---|
647 | ;; preceding non-clear simple section, end at the beginning of the next |
---|
648 | ;; non-clear simple section, and have the type defined by |
---|
649 | ;; `singular-simple-sec-clear-type'. Clear simple sections are |
---|
650 | ;; represented by nil. |
---|
651 | ;; - Buffer narrowing does not restrict the extent of completely or |
---|
652 | ;; partially inaccessible simple sections. But one should note that |
---|
653 | ;; some of the functions assume that there is no narrowing in |
---|
654 | ;; effect. |
---|
655 | ;; - After creation, simple sections are not modified any further. |
---|
656 | ;; |
---|
657 | ;; - In `singular-interactive-mode', the whole buffer is covered with |
---|
658 | ;; simple sections from the very beginning of the file up to the |
---|
659 | ;; beginning of the line containing the last input or output. The |
---|
660 | ;; remaining text up to `(point-max)' may be interpreted as covered by |
---|
661 | ;; one clear simple section. Thus, it is most reasonable to define |
---|
662 | ;; `input' to be the type of clear simple sections. |
---|
663 | |
---|
664 | (defvar singular-simple-sec-clear-type 'input |
---|
665 | "Type of clear simple sections. |
---|
666 | If nil no clear simple sections are used.") |
---|
667 | |
---|
668 | (defvar singular-simple-sec-last-end nil |
---|
669 | "Marker at the end of the last simple section. |
---|
670 | Should be initialized by `singular-simple-sec-init' before any calls to |
---|
671 | `singular-simple-sec-create' are done. |
---|
672 | |
---|
673 | This variable is buffer-local.") |
---|
674 | |
---|
675 | (defun singular-simple-sec-init (pos) |
---|
676 | "Initialize global variables belonging to simple section management. |
---|
677 | Creates the buffer-local marker `singular-simple-sec-last-end' and |
---|
678 | initializes it to POS." |
---|
679 | (make-local-variable 'singular-simple-sec-last-end) |
---|
680 | (if (not (markerp singular-simple-sec-last-end)) |
---|
681 | (setq singular-simple-sec-last-end (make-marker))) |
---|
682 | (set-marker singular-simple-sec-last-end pos)) |
---|
683 | |
---|
684 | ;; Note: |
---|
685 | ;; |
---|
686 | ;; The rest of the folding is either marked as |
---|
687 | ;; Emacs |
---|
688 | ;; or |
---|
689 | ;; XEmacs |
---|
690 | |
---|
691 | (singular-fset 'singular-simple-sec-create |
---|
692 | 'singular-emacs-simple-sec-create |
---|
693 | 'singular-xemacs-simple-sec-create) |
---|
694 | |
---|
695 | (singular-fset 'singular-simple-sec-reset-last |
---|
696 | 'singular-emacs-simple-sec-reset-last |
---|
697 | 'singular-xemacs-simple-sec-reset-last) |
---|
698 | |
---|
699 | (singular-fset 'singular-simple-sec-start |
---|
700 | 'singular-emacs-simple-sec-start |
---|
701 | 'singular-xemacs-simple-sec-start) |
---|
702 | |
---|
703 | (singular-fset 'singular-simple-sec-end |
---|
704 | 'singular-emacs-simple-sec-end |
---|
705 | 'singular-xemacs-simple-sec-end) |
---|
706 | |
---|
707 | (singular-fset 'singular-simple-sec-start-at |
---|
708 | 'singular-emacs-simple-sec-start-at |
---|
709 | 'singular-xemacs-simple-sec-start-at) |
---|
710 | |
---|
711 | (singular-fset 'singular-simple-sec-end-at |
---|
712 | 'singular-emacs-simple-sec-end-at |
---|
713 | 'singular-xemacs-simple-sec-end-at) |
---|
714 | |
---|
715 | (singular-fset 'singular-simple-sec-type |
---|
716 | 'singular-emacs-simple-sec-type |
---|
717 | 'singular-xemacs-simple-sec-type) |
---|
718 | |
---|
719 | (singular-fset 'singular-simple-sec-at |
---|
720 | 'singular-emacs-simple-sec-at |
---|
721 | 'singular-xemacs-simple-sec-at) |
---|
722 | |
---|
723 | (singular-fset 'singular-simple-sec-before |
---|
724 | 'singular-emacs-simple-sec-before |
---|
725 | 'singular-xemacs-simple-sec-before) |
---|
726 | |
---|
727 | (singular-fset 'singular-simple-sec-in |
---|
728 | 'singular-emacs-simple-sec-in |
---|
729 | 'singular-xemacs-simple-sec-in) |
---|
730 | ;;}}} |
---|
731 | |
---|
732 | ;;{{{ Simple section stuff for Emacs |
---|
733 | (defun singular-emacs-simple-sec-create (type end) |
---|
734 | "Create a new simple section of type TYPE. |
---|
735 | Creates the section from end of previous simple section up to END. |
---|
736 | END should be larger than `singular-simple-sec-last-end'. |
---|
737 | Returns the new simple section or `empty' if no simple section has |
---|
738 | been created. |
---|
739 | Assumes that no narrowing is in effect. |
---|
740 | Updates `singular-simple-sec-last-end'." |
---|
741 | (let ((last-end (marker-position singular-simple-sec-last-end)) |
---|
742 | ;; `simple-sec' is the new simple section or `empty' |
---|
743 | simple-sec) |
---|
744 | |
---|
745 | ;; get beginning of line before END. At this point we need that there |
---|
746 | ;; are no restrictions. |
---|
747 | (setq end (let ((old-point (point))) |
---|
748 | (goto-char end) (beginning-of-line) |
---|
749 | (prog1 (point) (goto-char old-point)))) |
---|
750 | |
---|
751 | (cond |
---|
752 | ;; do not create empty sections |
---|
753 | ((eq end last-end) (setq simple-sec 'empty)) |
---|
754 | ;; create only non-clear simple sections |
---|
755 | ((not (eq type singular-simple-sec-clear-type)) |
---|
756 | ;; if type has not changed we only have to extend the previous |
---|
757 | ;; simple section |
---|
758 | (setq simple-sec (singular-emacs-simple-sec-before last-end)) |
---|
759 | (if (eq type (singular-emacs-simple-sec-type simple-sec)) |
---|
760 | ;; move existing overlay |
---|
761 | (setq simple-sec (move-overlay simple-sec (overlay-start simple-sec) end)) |
---|
762 | ;; create new overlay |
---|
763 | (setq simple-sec (make-overlay last-end end)) |
---|
764 | ;; set type property |
---|
765 | (overlay-put simple-sec 'singular-type type) |
---|
766 | ;; set face |
---|
767 | (overlay-put simple-sec 'face (singular-lookup-face type)) |
---|
768 | ;; evaporate empty sections |
---|
769 | (overlay-put simple-sec 'evaporate t)))) |
---|
770 | |
---|
771 | ;; update end of last simple section |
---|
772 | (set-marker singular-simple-sec-last-end end) |
---|
773 | simple-sec)) |
---|
774 | |
---|
775 | (defun singular-emacs-simple-sec-reset-last (pos) |
---|
776 | "Reset end of last simple section to POS after accidental extension. |
---|
777 | Updates `singular-simple-sec-last-end', too." |
---|
778 | (let ((simple-sec (singular-emacs-simple-sec-at pos))) |
---|
779 | (if simple-sec (move-overlay simple-sec (overlay-start simple-sec) pos)) |
---|
780 | (set-marker singular-simple-sec-last-end pos))) |
---|
781 | |
---|
782 | (defun singular-emacs-simple-sec-start (simple-sec) |
---|
783 | "Return start of non-clear simple section SIMPLE-SEC." |
---|
784 | (overlay-start simple-sec)) |
---|
785 | |
---|
786 | (defun singular-emacs-simple-sec-end (simple-sec) |
---|
787 | "Return end of non-clear simple section SIMPLE-SEC." |
---|
788 | (overlay-end simple-sec)) |
---|
789 | |
---|
790 | (defun singular-emacs-simple-sec-start-at (pos) |
---|
791 | "Return start of clear section at position POS. |
---|
792 | Assumes that no narrowing is in effect." |
---|
793 | (let ((previous-overlay-change (1+ pos))) |
---|
794 | ;; this `while' loop at last will run into the end of the next |
---|
795 | ;; non-clear overlay or stop at bob. Since POS may be right at the end |
---|
796 | ;; of a previous non-clear location, we have to search at least one |
---|
797 | ;; time from POS+1 backwards. |
---|
798 | (while (not (or (singular-emacs-simple-sec-before previous-overlay-change) |
---|
799 | (eq previous-overlay-change (point-min)))) |
---|
800 | (setq previous-overlay-change |
---|
801 | (previous-overlay-change previous-overlay-change))) |
---|
802 | previous-overlay-change)) |
---|
803 | |
---|
804 | (defun singular-emacs-simple-sec-end-at (pos) |
---|
805 | "Return end of clear section at position POS. |
---|
806 | Assumes that no narrowing is in effect." |
---|
807 | (let ((next-overlay-change (next-overlay-change pos))) |
---|
808 | ;; this `while' loop at last will run into the beginning of the next |
---|
809 | ;; non-clear overlay or stop at eob. Since POS may not be at the |
---|
810 | ;; beginning of a non-clear simple section we may start searching |
---|
811 | ;; immediately. |
---|
812 | (while (not (or (singular-emacs-simple-sec-at next-overlay-change) |
---|
813 | (eq next-overlay-change (point-max)))) |
---|
814 | (setq next-overlay-change |
---|
815 | (next-overlay-change next-overlay-change))) |
---|
816 | next-overlay-change)) |
---|
817 | |
---|
818 | (defun singular-emacs-simple-sec-type (simple-sec) |
---|
819 | "Return type of SIMPLE-SEC." |
---|
820 | (if simple-sec |
---|
821 | (overlay-get simple-sec 'singular-type) |
---|
822 | singular-simple-sec-clear-type)) |
---|
823 | |
---|
824 | (defun singular-emacs-simple-sec-at (pos) |
---|
825 | "Return simple section at position POS." |
---|
826 | (let ((overlays (overlays-at pos)) simple-sec) |
---|
827 | ;; be careful, there may be other overlays! |
---|
828 | (while (and overlays (not simple-sec)) |
---|
829 | (if (singular-emacs-simple-sec-type (car overlays)) |
---|
830 | (setq simple-sec (car overlays))) |
---|
831 | (setq overlays (cdr overlays))) |
---|
832 | simple-sec)) |
---|
833 | |
---|
834 | (defun singular-emacs-simple-sec-before (pos) |
---|
835 | "Return simple section before position POS. |
---|
836 | This is the same as `singular-simple-section-at' except if POS falls |
---|
837 | on a section border. In this case `singular-simple-section-before' |
---|
838 | returns the previous simple section instead of the current one." |
---|
839 | (singular-emacs-simple-sec-at (max 1 (1- pos)))) |
---|
840 | |
---|
841 | (defun singular-emacs-simple-sec-in (beg end) |
---|
842 | "Return a list of all simple sections intersecting with the region from BEG to END. |
---|
843 | A simple section intersects the region if the section and the region |
---|
844 | have at least one character in common. |
---|
845 | The result contains both clear and non-clear simple sections in the |
---|
846 | order in that the appear in the region." |
---|
847 | ;; NOT READY |
---|
848 | nil) |
---|
849 | ;;}}} |
---|
850 | |
---|
851 | ;;{{{ Simple section stuff for XEmacs |
---|
852 | (defun singular-xemacs-simple-sec-create (type end) |
---|
853 | "Create a new simple section of type TYPE. |
---|
854 | Creates the section from end of previous simple section up to END. |
---|
855 | END should be larger than `singular-simple-sec-last-end'. |
---|
856 | Returns the new simple section or `empty' if no simple section has |
---|
857 | been created. |
---|
858 | Assumes that no narrowing is in effect. |
---|
859 | Updates `singular-simple-sec-last-end'." |
---|
860 | (let ((last-end (marker-position singular-simple-sec-last-end)) |
---|
861 | ;; `simple-sec' is the new simple section or `empty' |
---|
862 | simple-sec) |
---|
863 | |
---|
864 | ;; get beginning of line before END. At this point we need that there |
---|
865 | ;; are no restrictions. |
---|
866 | (setq end (let ((old-point (point))) |
---|
867 | (goto-char end) (beginning-of-line) |
---|
868 | (prog1 (point) (goto-char old-point)))) |
---|
869 | |
---|
870 | (cond |
---|
871 | ;; do not create empty sections |
---|
872 | ((eq end last-end) (setq simple-sec 'empty)) |
---|
873 | ;; create only non-clear simple sections |
---|
874 | ((not (eq type singular-simple-sec-clear-type)) |
---|
875 | ;; if type has not changed we only have to extend the previous |
---|
876 | ;; simple section |
---|
877 | (setq simple-sec (singular-xemacs-simple-sec-before last-end)) |
---|
878 | (if (eq type (singular-xemacs-simple-sec-type simple-sec)) |
---|
879 | ;; move existing extent |
---|
880 | (setq simple-sec (set-extent-endpoints simple-sec |
---|
881 | (extent-start-position simple-sec) end)) |
---|
882 | ;; create new extent |
---|
883 | (setq simple-sec (make-extent last-end end)) |
---|
884 | ;; set type property |
---|
885 | (set-extent-property simple-sec 'singular-type type) |
---|
886 | ;; set face |
---|
887 | (set-extent-property simple-sec 'face (singular-lookup-face type))))) |
---|
888 | |
---|
889 | ;; update end of last simple section |
---|
890 | (set-marker singular-simple-sec-last-end end) |
---|
891 | simple-sec)) |
---|
892 | |
---|
893 | (defun singular-xemacs-simple-sec-reset-last (pos) |
---|
894 | "Reset end of last simple section to POS after accidental extension. |
---|
895 | Updates `singular-simple-sec-last-end', too." |
---|
896 | (let ((simple-sec (singular-xemacs-simple-sec-at pos))) |
---|
897 | (if simple-sec |
---|
898 | (set-extent-endpoints simple-sec (extent-start-position simple-sec) pos)) |
---|
899 | (set-marker singular-simple-sec-last-end pos))) |
---|
900 | |
---|
901 | (defun singular-xemacs-simple-sec-start (simple-sec) |
---|
902 | "Return start of non-clear simple section SIMPLE-SEC." |
---|
903 | (extent-start-position simple-sec)) |
---|
904 | |
---|
905 | (defun singular-xemacs-simple-sec-end (simple-sec) |
---|
906 | "Return end of non-clear simple section SIMPLE-SEC." |
---|
907 | (extent-end-position simple-sec)) |
---|
908 | |
---|
909 | (defun singular-xemacs-simple-sec-start-at (pos) |
---|
910 | "Return start of clear section at position POS. |
---|
911 | Assumes that no narrowing is in effect." |
---|
912 | ;; if previous-extent-change is called with an argument bigger |
---|
913 | ;; than (1+ (buffer-size)) (not (point-max)!), we get an error! |
---|
914 | (let ((previous-extent-change (if (> pos (buffer-size)) |
---|
915 | pos |
---|
916 | (1+ pos)))) |
---|
917 | ;; this `while' loop at last will run into the end of the next |
---|
918 | ;; non-clear extent or stop at bob. Since POS may be right at the end |
---|
919 | ;; of a previous non-clear location, we have to search at least one |
---|
920 | ;; time from POS+1 backwards. |
---|
921 | (while (not (or (singular-xemacs-simple-sec-before previous-extent-change) |
---|
922 | (eq previous-extent-change (point-min)))) |
---|
923 | (setq previous-extent-change |
---|
924 | (previous-extent-change previous-extent-change))) |
---|
925 | previous-extent-change)) |
---|
926 | |
---|
927 | (defun singular-xemacs-simple-sec-end-at (pos) |
---|
928 | "Return end of clear section at position POS. |
---|
929 | Assumes that no narrowing is in effect." |
---|
930 | (let ((next-extent-change (next-extent-change pos))) |
---|
931 | ;; this `while' loop at last will run into the beginning of the next |
---|
932 | ;; non-clear extent or stop at eob. Since POS may not be at the |
---|
933 | ;; beginning of a non-clear simple section we may start searching |
---|
934 | ;; immediately. |
---|
935 | (while (not (or (singular-xemacs-simple-sec-at next-extent-change) |
---|
936 | (eq next-extent-change (point-max)))) |
---|
937 | (setq next-extent-change |
---|
938 | (next-extent-change next-extent-change))) |
---|
939 | next-extent-change)) |
---|
940 | |
---|
941 | (defun singular-xemacs-simple-sec-type (simple-sec) |
---|
942 | "Return type of SIMPLE-SEC." |
---|
943 | (if simple-sec |
---|
944 | (extent-property simple-sec 'singular-type) |
---|
945 | singular-simple-sec-clear-type)) |
---|
946 | |
---|
947 | (defun singular-xemacs-simple-sec-at (pos) |
---|
948 | "Return simple section at position POS." |
---|
949 | (map-extents (function (lambda (ext args) ext)) |
---|
950 | ;; is this pos-pos-region OK? I think so. |
---|
951 | (current-buffer) pos pos nil nil 'singular-type)) |
---|
952 | |
---|
953 | (defun singular-xemacs-simple-sec-before (pos) |
---|
954 | "Return simple section before position POS. |
---|
955 | This is the same as `singular-simple-section-at' except if POS falls |
---|
956 | on a section border. In this case `singular-simple-section-before' |
---|
957 | returns the previous simple section instead of the current one." |
---|
958 | (singular-xemacs-simple-sec-at (max 1 (1- pos)))) |
---|
959 | |
---|
960 | (defun singular-xemacs-simple-sec-in (beg end) |
---|
961 | "Return a list of all simple sections intersecting with the region from BEG to END. |
---|
962 | A simple section intersects the region if the section and the region |
---|
963 | have at least one character in common. |
---|
964 | The result contains both clear and non-clear simple sections in the |
---|
965 | order they appear in the region." |
---|
966 | ;; NOT READY [order of sections???] |
---|
967 | (let ((extent-list)) |
---|
968 | (map-extents |
---|
969 | (function (lambda (ext arg) |
---|
970 | |
---|
971 | ;; if start of first extent is not point-min, insert |
---|
972 | ;; a clear-simple-sec first: |
---|
973 | (or extent-list |
---|
974 | (= (extent-start-position ext) (point-min)) |
---|
975 | (setq extent-list (append (list nil) extent-list))) |
---|
976 | |
---|
977 | ;; if end of previous simple-sec is not equal start of |
---|
978 | ;; current simple-sec than we have to insert a |
---|
979 | ;; clear-simple-sec first: |
---|
980 | (and (car extent-list) |
---|
981 | (not (= (extent-end-position (car extent-list)) |
---|
982 | (extent-start-position ext))) |
---|
983 | (setq extent-list (append (list nil) extent-list))) |
---|
984 | |
---|
985 | ;; finally insert this non-clear simple-sec: |
---|
986 | (setq extent-list (append (list ext) extent-list)) |
---|
987 | nil)) |
---|
988 | (current-buffer) beg end nil nil 'singular-type) |
---|
989 | |
---|
990 | ;; if extent-list is still nil at this point, then no non-clear |
---|
991 | ;; simple-sec intersects with region (BEG END). |
---|
992 | ;; Then insert a clear simple-sec: |
---|
993 | (or extent-list |
---|
994 | (setq extent-list '(nil))) |
---|
995 | |
---|
996 | ;; if last inserted simple-sec is non-clear and its end is smaller |
---|
997 | ;; than END, then insert another clear simple sec: |
---|
998 | (and (car extent-list) |
---|
999 | (<= (extent-end-position (car extent-list)) end) |
---|
1000 | (setq extent-list (append (list nil) extent-list))) |
---|
1001 | |
---|
1002 | ;; we set up the list in decreasing order, so reverse the list |
---|
1003 | (reverse extent-list))) |
---|
1004 | ;;}}} |
---|
1005 | |
---|
1006 | ;;{{{ Section stuff |
---|
1007 | |
---|
1008 | ;; Note: |
---|
1009 | ;; |
---|
1010 | ;; Sections are built on simple sections. Their purpose is to cover the |
---|
1011 | ;; difference between clear and non-clear simple sections. |
---|
1012 | ;; |
---|
1013 | ;; - Sections consist of a simple section, its type, and its start and end |
---|
1014 | ;; points. This is redundant information only in the case of non-clear |
---|
1015 | ;; simple section. |
---|
1016 | ;; - Sections are read-only objects, neither are they modified nor are they |
---|
1017 | ;; created. |
---|
1018 | ;; - Buffer narrowing does not restrict the extent of completely or |
---|
1019 | ;; partially inaccessible sections. In contrast to simple sections |
---|
1020 | ;; the functions concerning sections do not assume that there is no |
---|
1021 | ;; narrowing in effect. |
---|
1022 | ;; - Sections are independent from implementation dependencies. There are |
---|
1023 | ;; no different versions of the functions for Emacs and XEmacs. |
---|
1024 | |
---|
1025 | (defun singular-section-at (pos &optional restricted) |
---|
1026 | "Return section at position POS. |
---|
1027 | Returns section intersected with current restriction if RESTRICTED is |
---|
1028 | non-nil." |
---|
1029 | (let* ((simple-sec (singular-simple-sec-at pos)) |
---|
1030 | (type (singular-simple-sec-type simple-sec)) |
---|
1031 | start end) |
---|
1032 | (if simple-sec |
---|
1033 | (setq start (singular-simple-sec-start simple-sec) |
---|
1034 | end (singular-simple-sec-end simple-sec)) |
---|
1035 | (save-restriction |
---|
1036 | (widen) |
---|
1037 | (setq start (singular-simple-sec-start-at pos) |
---|
1038 | end (singular-simple-sec-end-at pos)))) |
---|
1039 | (if restricted |
---|
1040 | (vector simple-sec type |
---|
1041 | (max start (point-min)) (min end (point-max))) |
---|
1042 | (vector simple-sec type start end)))) |
---|
1043 | |
---|
1044 | (defun singular-section-before (pos &optional restricted) |
---|
1045 | "Return section before position POS. |
---|
1046 | This is the same as `singular-section-at' except if POS falls on a |
---|
1047 | section border. In this case `singular-section-before' returns the |
---|
1048 | previous section instead of the current one. |
---|
1049 | Returns section intersected with current restriction if RESTRICTED is |
---|
1050 | non-nil." |
---|
1051 | (singular-section-at (max 1 (1- pos)) restricted)) |
---|
1052 | |
---|
1053 | (defun singular-section-in (reg-beg reg-end) |
---|
1054 | "NOT READY [docu]" |
---|
1055 | (let ((simple-secs (singular-simple-sec-in reg-beg reg-end)) |
---|
1056 | sections current last-end |
---|
1057 | type beg end) |
---|
1058 | (save-restriction |
---|
1059 | (widen) |
---|
1060 | (while simple-secs |
---|
1061 | (setq current (car simple-secs)) |
---|
1062 | (setq type (singular-simple-sec-type current)) |
---|
1063 | (if current |
---|
1064 | ;; current is a non-clear simple-sec |
---|
1065 | (setq beg (singular-simple-sec-start current) |
---|
1066 | end (singular-simple-sec-end current) |
---|
1067 | last-end end) |
---|
1068 | ;; current is a clear simple-sec |
---|
1069 | (setq beg (singular-simple-sec-start-at (or last-end |
---|
1070 | (point-min))) |
---|
1071 | end (singular-simple-sec-end-at (or last-end |
---|
1072 | (point-min))))) |
---|
1073 | ;; NOT READY [RESTRICTED] |
---|
1074 | (setq sections (append sections (list (vector current type beg end)))) |
---|
1075 | (setq simple-secs (cdr simple-secs)))) |
---|
1076 | sections)) |
---|
1077 | |
---|
1078 | (defmacro singular-section-simple-sec (section) |
---|
1079 | "Return underlying simple section of SECTION." |
---|
1080 | `(aref ,section 0)) |
---|
1081 | |
---|
1082 | (defmacro singular-section-type (section) |
---|
1083 | "Return type of SECTION." |
---|
1084 | `(aref ,section 1)) |
---|
1085 | |
---|
1086 | (defmacro singular-section-start (section) |
---|
1087 | "Return start of SECTION." |
---|
1088 | `(aref ,section 2)) |
---|
1089 | |
---|
1090 | (defmacro singular-section-end (section) |
---|
1091 | "Return end of SECTION." |
---|
1092 | `(aref ,section 3)) |
---|
1093 | ;;}}} |
---|
1094 | |
---|
1095 | ;;{{{ Getting section contents |
---|
1096 | (defun singular-input-section-to-string (section &optional end raw) |
---|
1097 | "Get content of SECTION as string. |
---|
1098 | Returns text between start of SECTION and END if optional argument END |
---|
1099 | is non-nil. END should be a position inside SECTION. |
---|
1100 | Strips leading prompts and trailing white space unless optional argument |
---|
1101 | RAW is non-nil." |
---|
1102 | (save-restriction |
---|
1103 | (widen) |
---|
1104 | (let ((string (if end |
---|
1105 | (buffer-substring (singular-section-start section) end) |
---|
1106 | (buffer-substring (singular-section-start section) |
---|
1107 | (singular-section-end section))))) |
---|
1108 | (if raw string |
---|
1109 | (singular-strip-leading-prompt |
---|
1110 | (singular-strip-white-space string t)))))) |
---|
1111 | ;;}}} |
---|
1112 | |
---|
1113 | ;;{{{ Last input and output section |
---|
1114 | (defun singular-last-input-section (&optional no-error) |
---|
1115 | "Return last input section. |
---|
1116 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
1117 | last input section defined, throws an error otherwise." |
---|
1118 | (let ((last-input-start (marker-position singular-last-input-section-start)) |
---|
1119 | (last-input-end (marker-position singular-current-output-section-start))) |
---|
1120 | (cond ((and last-input-start last-input-end) |
---|
1121 | (vector (singular-simple-sec-at last-input-start) 'input |
---|
1122 | last-input-start last-input-end)) |
---|
1123 | (no-error nil) |
---|
1124 | (t (error "No last input section defined"))))) |
---|
1125 | |
---|
1126 | (defun singular-current-output-section (&optional no-error) |
---|
1127 | "Return current output section. |
---|
1128 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
1129 | current output section defined, throws an error otherwise." |
---|
1130 | (let ((current-output-start (marker-position singular-current-output-section-start)) |
---|
1131 | (current-output-end (save-excursion |
---|
1132 | (goto-char (singular-process-mark)) |
---|
1133 | (singular-skip-prompt-backward) |
---|
1134 | (and (bolp) (point))))) |
---|
1135 | (cond ((and current-output-start current-output-end) |
---|
1136 | (vector (singular-simple-sec-at current-output-start) 'output |
---|
1137 | current-output-start current-output-end)) |
---|
1138 | (no-error nil) |
---|
1139 | (t (error "No current output section defined"))))) |
---|
1140 | |
---|
1141 | (defun singular-last-output-section (&optional no-error) |
---|
1142 | "Return last output section. |
---|
1143 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
1144 | last output section defined, throws an error otherwise." |
---|
1145 | (let ((last-output-start (marker-position singular-last-output-section-start)) |
---|
1146 | (last-output-end (marker-position singular-last-input-section-start))) |
---|
1147 | (cond ((and last-output-start last-output-end) |
---|
1148 | (vector (singular-simple-sec-at last-output-start) 'output |
---|
1149 | last-output-start last-output-end)) |
---|
1150 | (no-error nil) |
---|
1151 | (t (error "No last output section defined"))))) |
---|
1152 | |
---|
1153 | (defun singular-latest-output-section (&optional no-error) |
---|
1154 | "Return latest output section. |
---|
1155 | This is the current output section if it is defined, otherwise the |
---|
1156 | last output section. |
---|
1157 | Returns nil if optional argument NO-ERROR is non-nil and there is no |
---|
1158 | latest output section defined, throws an error otherwise." |
---|
1159 | (or (singular-current-output-section t) |
---|
1160 | (singular-last-output-section t) |
---|
1161 | (if no-error |
---|
1162 | nil |
---|
1163 | (error "No latest output section defined")))) |
---|
1164 | ;;}}} |
---|
1165 | |
---|
1166 | ;;{{{ Folding sections |
---|
1167 | (defvar singular-folding-ellipsis "Singular I/O ..." |
---|
1168 | "Ellipsis to show for folded input or output.") |
---|
1169 | |
---|
1170 | (defun singular-fold-internal (start end fold) |
---|
1171 | "(Un)fold region from START to END. |
---|
1172 | Folds if FOLD is non-nil, otherwise unfolds. |
---|
1173 | Folding affects undo information and buffer modified flag. |
---|
1174 | Assumes that there is no narrowing in effect." |
---|
1175 | (save-excursion |
---|
1176 | (if fold |
---|
1177 | (progn |
---|
1178 | (goto-char start) (insert ?\r) |
---|
1179 | (subst-char-in-region start end ?\n ?\r t)) |
---|
1180 | (subst-char-in-region start end ?\r ?\n t) |
---|
1181 | (goto-char start) (delete-char 1)))) |
---|
1182 | |
---|
1183 | (defun singular-section-foldedp (section) |
---|
1184 | "Return t iff SECTION is folded. |
---|
1185 | Assumes that there is no narrowing in effect." |
---|
1186 | (eq (char-after (singular-section-start section)) ?\r)) |
---|
1187 | |
---|
1188 | (defun singular-fold-section (section) |
---|
1189 | "\(Un)fold SECTION. |
---|
1190 | \(Un)folds section at point and goes to beginning of section if called |
---|
1191 | interactively. |
---|
1192 | Unfolds folded sections and folds unfolded sections." |
---|
1193 | (interactive (list (singular-section-at (point)))) |
---|
1194 | (let ((start (singular-section-start section)) |
---|
1195 | ;; we have to save restrictions this way since we change text |
---|
1196 | ;; outside the restriction. Note that we do not use a marker for |
---|
1197 | ;; `old-point-min'. This way, even partial narrowed sections are |
---|
1198 | ;; folded properly if they have been narrowed at bol. Nice but |
---|
1199 | ;; dirty trick: The insertion of a `?\r' at beginning of section |
---|
1200 | ;; advances the beginning of the restriction such that it displays |
---|
1201 | ;; the `?\r' immediately before bol. Seems worth it. |
---|
1202 | (old-point-min (point-min)) |
---|
1203 | (old-point-max (point-max-marker))) |
---|
1204 | (unwind-protect |
---|
1205 | (progn |
---|
1206 | (widen) |
---|
1207 | (singular-fold-internal start (singular-section-end section) |
---|
1208 | (not (singular-section-foldedp section)))) |
---|
1209 | ;; this is unwide-protected |
---|
1210 | (narrow-to-region old-point-min old-point-max) |
---|
1211 | (set-marker old-point-max nil)) |
---|
1212 | (if (interactive-p) (goto-char (max start (point-min)))))) |
---|
1213 | |
---|
1214 | (defun singular-do-folding (where &optional unfold) |
---|
1215 | "Fold or unfold certain sections. |
---|
1216 | WHERE may be 'last, 'all, or 'at-point. If WHERE equals 'last or |
---|
1217 | 'all, only output sections are affected. If WHERE equals 'at-point, |
---|
1218 | the section at point is affected (input or output). |
---|
1219 | If optional argument UNFOLD is non-nil, then unfold section instead |
---|
1220 | of folding it." |
---|
1221 | (let (which) |
---|
1222 | (cond |
---|
1223 | ((eq where 'last) |
---|
1224 | (setq which (list (singular-latest-output-section t)))) |
---|
1225 | |
---|
1226 | ((eq where 'at-point) |
---|
1227 | (setq which (list (singular-section-at (point))))) |
---|
1228 | |
---|
1229 | ((eq where 'all) |
---|
1230 | (setq which (singular-section-in (point-min) (point-max))) |
---|
1231 | |
---|
1232 | ;; just use the output sections: |
---|
1233 | (let (newwhich) |
---|
1234 | (while which |
---|
1235 | (if (eq (singular-section-type (car which)) 'output) |
---|
1236 | (setq newwhich (append (list (car which)) newwhich))) |
---|
1237 | (setq which (cdr which))) |
---|
1238 | (setq which newwhich))) |
---|
1239 | |
---|
1240 | (t |
---|
1241 | (singular-debug 'interactive |
---|
1242 | (message "singular-do-folding: wrong argument")))) |
---|
1243 | (while which |
---|
1244 | (let* ((current (car which)) |
---|
1245 | (is-folded (singular-section-foldedp current))) |
---|
1246 | (and (if unfold is-folded (not is-folded)) |
---|
1247 | (singular-fold-section current))) |
---|
1248 | (setq which (cdr which)))) |
---|
1249 | ;; NOT READY: HACK: recenter (because of error in subst-char-in-region!?!) |
---|
1250 | (recenter)) |
---|
1251 | |
---|
1252 | (defun singular-fold-last-output () |
---|
1253 | "Fold last output section. |
---|
1254 | If it is already folded, do nothing." |
---|
1255 | (interactive) |
---|
1256 | (singular-do-folding 'last)) |
---|
1257 | |
---|
1258 | (defun singular-fold-all-output () |
---|
1259 | "Fold all output sections." |
---|
1260 | (interactive) |
---|
1261 | (singular-do-folding 'all)) |
---|
1262 | |
---|
1263 | (defun singular-fold-at-point |
---|
1264 | "Fold section at point (input or output section). |
---|
1265 | If it is already folded, do nothing." |
---|
1266 | (interactive) |
---|
1267 | (singular-do-folding 'at-point)) |
---|
1268 | |
---|
1269 | (defun singular-unfold-last-output () |
---|
1270 | "Unfold last output section. |
---|
1271 | If it is already unfolded, do nothing." |
---|
1272 | (interactive) |
---|
1273 | (singular-do-folding 'last 'unfold)) |
---|
1274 | |
---|
1275 | (defun singular-unfold-all-output () |
---|
1276 | "Unfold all output section." |
---|
1277 | (interactive) |
---|
1278 | (singular-do-folding 'all 'unfold)) |
---|
1279 | |
---|
1280 | (defun singular-unfold-at-point () |
---|
1281 | "Unfold section at point (input or output section). |
---|
1282 | If it is already unfolded, do nothing." |
---|
1283 | (interactive) |
---|
1284 | (singular-do-folding 'at-point 'unfold)) |
---|
1285 | ;;}}} |
---|
1286 | |
---|
1287 | ;;{{{ Input and output filters |
---|
1288 | |
---|
1289 | ;; debugging filters |
---|
1290 | (defun singular-debug-pre-input-filter (string) |
---|
1291 | "Display STRING and some markers in mini-buffer." |
---|
1292 | (singular-debug 'interactive-filter |
---|
1293 | (message "Pre-input filter: %s" |
---|
1294 | (singular-debug-format string))) |
---|
1295 | (singular-debug 'interactive-filter |
---|
1296 | (message "Pre-input filter: (li %S ci %S lo %S co %S)" |
---|
1297 | (marker-position singular-last-input-section-start) |
---|
1298 | (marker-position singular-current-input-section-start) |
---|
1299 | (marker-position singular-last-output-section-start) |
---|
1300 | (marker-position singular-current-output-section-start))) |
---|
1301 | nil) |
---|
1302 | |
---|
1303 | (defun singular-debug-post-input-filter (beg end) |
---|
1304 | "Display BEG, END, and some markers in mini-buffer." |
---|
1305 | (singular-debug 'interactive-filter |
---|
1306 | (message "Post-input filter: (beg %S end %S)" beg end)) |
---|
1307 | (singular-debug 'interactive-filter |
---|
1308 | (message "Post-input filter: (li %S ci %S lo %S co %S)" |
---|
1309 | (marker-position singular-last-input-section-start) |
---|
1310 | (marker-position singular-current-input-section-start) |
---|
1311 | (marker-position singular-last-output-section-start) |
---|
1312 | (marker-position singular-current-output-section-start)))) |
---|
1313 | |
---|
1314 | (defun singular-debug-pre-output-filter (string) |
---|
1315 | "Display STRING and some markers in mini-buffer." |
---|
1316 | (singular-debug 'interactive-filter |
---|
1317 | (message "Pre-output filter: %s" |
---|
1318 | (singular-debug-format string))) |
---|
1319 | (singular-debug 'interactive-filter |
---|
1320 | (message "Pre-output filter: (li %S ci %S lo %S co %S)" |
---|
1321 | (marker-position singular-last-input-section-start) |
---|
1322 | (marker-position singular-current-input-section-start) |
---|
1323 | (marker-position singular-last-output-section-start) |
---|
1324 | (marker-position singular-current-output-section-start))) |
---|
1325 | nil) |
---|
1326 | |
---|
1327 | (defun singular-debug-post-output-filter (beg end simple-sec-start) |
---|
1328 | "Display BEG, END, SIMPLE-SEC-START, and some markers in mini-buffer." |
---|
1329 | (singular-debug 'interactive-filter |
---|
1330 | (message "Post-output filter: (beg %S end %S sss %S)" |
---|
1331 | beg end simple-sec-start)) |
---|
1332 | (singular-debug 'interactive-filter |
---|
1333 | (message "Post-output filter: (li %S ci %S lo %S co %S)" |
---|
1334 | (marker-position singular-last-input-section-start) |
---|
1335 | (marker-position singular-current-input-section-start) |
---|
1336 | (marker-position singular-last-output-section-start) |
---|
1337 | (marker-position singular-current-output-section-start)))) |
---|
1338 | |
---|
1339 | ;; stripping prompts |
---|
1340 | (defun singular-remove-prompt-filter (beg end simple-sec-start) |
---|
1341 | "Strip prompts from last simple section." |
---|
1342 | (if simple-sec-start (singular-remove-prompt simple-sec-start end))) |
---|
1343 | ;;}}} |
---|
1344 | |
---|
1345 | ;;{{{ Demo mode |
---|
1346 | (defvar singular-demo-chunk-regexp "\\(\n\n\\)" |
---|
1347 | "Regular expressions to recognize chunks of a demo file. |
---|
1348 | If there is a subexpression specified its content is removed when the |
---|
1349 | chunk is displayed.") |
---|
1350 | |
---|
1351 | (defvar singular-demo-print-messages t |
---|
1352 | "If non-nil, print message on how to continue demo mode") |
---|
1353 | |
---|
1354 | (defvar singular-demo-mode nil |
---|
1355 | "Non-nil if Singular demo mode is on. |
---|
1356 | |
---|
1357 | This variable is buffer-local.") |
---|
1358 | |
---|
1359 | (defvar singular-demo-old-mode-name nil |
---|
1360 | "Used to store previous `mode-name' before switching to demo mode. |
---|
1361 | |
---|
1362 | This variable is buffer-local.") |
---|
1363 | |
---|
1364 | (defvar singular-demo-end nil |
---|
1365 | "Marker pointing to end of demo file. |
---|
1366 | |
---|
1367 | This variable is buffer-local.") |
---|
1368 | |
---|
1369 | (defvar singular-demo-command-on-enter nil |
---|
1370 | "Singular command to send when entering demo mode or nil if no string to send.") |
---|
1371 | |
---|
1372 | (defvar singular-demo-command-on-leave nil |
---|
1373 | "Singular command to send when leaving demo mode or nil if no string to send.") |
---|
1374 | |
---|
1375 | (defun singular-demo-mode (mode) |
---|
1376 | "Switch between demo mode states. |
---|
1377 | MODE may be either: |
---|
1378 | - `init' to initialize global variables; |
---|
1379 | - `exit' to clean up demo and leave Singular demo mode; |
---|
1380 | - `enter' to enter Singular demo mode; |
---|
1381 | - `leave' to leave Singular demo mode. |
---|
1382 | |
---|
1383 | Modifies the global variables `singular-demo-mode', |
---|
1384 | `singular-demo-end', and `singular-demo-old-mode-name' to reflect the |
---|
1385 | new state of Singular demo mode." |
---|
1386 | (cond |
---|
1387 | ;; initialization. Should be called only once. |
---|
1388 | ((eq mode 'init) |
---|
1389 | (make-local-variable 'singular-demo-mode) |
---|
1390 | (make-local-variable 'singular-demo-mode-old-name) |
---|
1391 | (make-local-variable 'singular-demo-mode-end) |
---|
1392 | (if (not (and (boundp 'singular-demo-end) |
---|
1393 | singular-demo-end)) |
---|
1394 | (setq singular-demo-end (make-marker)))) |
---|
1395 | |
---|
1396 | ;; final exit. Clean up demo. |
---|
1397 | ((and (eq mode 'exit) |
---|
1398 | singular-demo-mode) |
---|
1399 | (setq mode-name singular-demo-old-mode-name |
---|
1400 | singular-demo-mode nil) |
---|
1401 | ;; clean up hidden rest of demo file if existent |
---|
1402 | (let ((old-point-min (point-min)) |
---|
1403 | (old-point-max (point-max))) |
---|
1404 | (unwind-protect |
---|
1405 | (progn |
---|
1406 | (widen) |
---|
1407 | (delete-region old-point-max singular-demo-end)) |
---|
1408 | ;; this is unwide-protected |
---|
1409 | (narrow-to-region old-point-min old-point-max))) |
---|
1410 | (if (and singular-demo-command-on-leave |
---|
1411 | (singular-process)) |
---|
1412 | (send-string (singular-process) singular-demo-command-on-leave)) |
---|
1413 | (force-mode-line-update)) |
---|
1414 | |
---|
1415 | ;; enter demo mode |
---|
1416 | ((and (eq mode 'enter) |
---|
1417 | (not singular-demo-mode)) |
---|
1418 | (setq singular-demo-old-mode-name mode-name |
---|
1419 | mode-name "Singular Demo" |
---|
1420 | singular-demo-mode t) |
---|
1421 | (if singular-demo-command-on-enter |
---|
1422 | (send-string (singular-process) singular-demo-command-on-enter)) |
---|
1423 | (if singular-demo-print-messages |
---|
1424 | (message "Hit RET to start demo")) |
---|
1425 | (force-mode-line-update)) |
---|
1426 | |
---|
1427 | ;; leave demo mode |
---|
1428 | ((and (eq mode 'leave) |
---|
1429 | singular-demo-mode) |
---|
1430 | (setq mode-name singular-demo-old-mode-name |
---|
1431 | singular-demo-mode nil) |
---|
1432 | (if singular-demo-command-on-leave |
---|
1433 | (send-string (singular-process) singular-demo-command-on-leave)) |
---|
1434 | (force-mode-line-update)))) |
---|
1435 | |
---|
1436 | (defun singular-demo-exit () |
---|
1437 | "Prematurely exit singular demo mode." |
---|
1438 | (interactive) |
---|
1439 | (singular-demo-mode 'exit)) |
---|
1440 | |
---|
1441 | (defun singular-demo-show-next-chunk () |
---|
1442 | "Show next chunk of demo file at input prompt. |
---|
1443 | Moves point to end of buffer and widenes the buffer such that the next |
---|
1444 | chunk of the demo file becomes visible. |
---|
1445 | Finds and removes chunk separators as specified by |
---|
1446 | `singular-demo-chunk-regexp'. |
---|
1447 | Removing chunk separators affects undo information and buffer-modified |
---|
1448 | flag. |
---|
1449 | Leaves demo mode after showing last chunk." |
---|
1450 | (let ((old-point-min (point-min))) |
---|
1451 | (unwind-protect |
---|
1452 | (progn |
---|
1453 | (goto-char (point-max)) |
---|
1454 | (widen) |
---|
1455 | (if (re-search-forward singular-demo-chunk-regexp singular-demo-end 'limit) |
---|
1456 | (and (match-beginning 1) |
---|
1457 | (delete-region (match-beginning 1) (match-end 1))) |
---|
1458 | ;; remove trailing white-space |
---|
1459 | (skip-syntax-backward "-") |
---|
1460 | (delete-region (point) singular-demo-end) |
---|
1461 | (singular-demo-mode 'leave))) |
---|
1462 | |
---|
1463 | ;; this is unwind-protected |
---|
1464 | (narrow-to-region old-point-min (point))))) |
---|
1465 | |
---|
1466 | (defun singular-demo-load (demo-file) |
---|
1467 | "Load demo file DEMO-FILE and enter Singular demo mode. |
---|
1468 | For a description of the Singular demo mode one should refer to the |
---|
1469 | doc-string of `singular-interactive-mode'. |
---|
1470 | Moves point to end of buffer and inserts contents of DEMO-FILE there." |
---|
1471 | (interactive "fLoad demo file: ") |
---|
1472 | |
---|
1473 | ;; check for running demo |
---|
1474 | (and singular-demo-mode |
---|
1475 | (error "Another demo is already running")) |
---|
1476 | |
---|
1477 | (let ((old-point-min (point-min))) |
---|
1478 | (unwind-protect |
---|
1479 | (progn |
---|
1480 | (goto-char (point-max)) |
---|
1481 | (widen) |
---|
1482 | ;; load file and remember its end |
---|
1483 | (set-marker singular-demo-end |
---|
1484 | (+ (point) (nth 1 (insert-file-contents demo-file))))) |
---|
1485 | |
---|
1486 | ;; completely hide demo file. |
---|
1487 | ;; This is unwide protected. |
---|
1488 | (narrow-to-region old-point-min (point))) |
---|
1489 | |
---|
1490 | ;; switch demo mode on |
---|
1491 | (singular-demo-mode 'enter))) |
---|
1492 | ;;}}} |
---|
1493 | |
---|
1494 | ;;{{{ Some lengthy notes on input and output |
---|
1495 | |
---|
1496 | ;; NOT READY[so sorry]! |
---|
1497 | |
---|
1498 | ;;}}} |
---|
1499 | |
---|
1500 | ;;{{{ Sending input |
---|
1501 | (defvar singular-pre-input-filter-functions nil |
---|
1502 | "Functions to call before input is sent to process. |
---|
1503 | These functions get one argument, a string containing the text which |
---|
1504 | is to be sent to process. The functions should return either nil |
---|
1505 | or a string. In the latter case the returned string replaces the |
---|
1506 | string to be sent to process. |
---|
1507 | |
---|
1508 | This is a buffer-local variable, not a buffer-local hook! |
---|
1509 | |
---|
1510 | `singular-run-hook-with-arg-and-value' is used to run the functions in |
---|
1511 | the list.") |
---|
1512 | |
---|
1513 | (defvar singular-post-input-filter-functions nil |
---|
1514 | "Functions to call after input is sent to process. |
---|
1515 | These functions get two arguments BEG and END. |
---|
1516 | If `singular-input-filter' has been called with a string as argument |
---|
1517 | BEG and END gives the position of this string after insertion into the |
---|
1518 | buffer. |
---|
1519 | If `singular-input-filter' has been called with a position as argument |
---|
1520 | BEG and END equal process mark and that position, resp. |
---|
1521 | The functions may assume that no narrowing is in effect and may change |
---|
1522 | point at will. |
---|
1523 | |
---|
1524 | This hook is buffer-local.") |
---|
1525 | |
---|
1526 | (defvar singular-current-input-section-start nil |
---|
1527 | "Marker to the start of the current input section. |
---|
1528 | This marker points nowhere on startup or if there is no current input |
---|
1529 | section. |
---|
1530 | |
---|
1531 | This variable is buffer-local.") |
---|
1532 | |
---|
1533 | (defvar singular-last-input-section-start nil |
---|
1534 | "Marker to the start of the last input section. |
---|
1535 | This marker points nowhere on startup. |
---|
1536 | |
---|
1537 | This variable is buffer-local.") |
---|
1538 | |
---|
1539 | (defun singular-input-filter-init (pos) |
---|
1540 | "Initialize all variables concerning input. |
---|
1541 | POS is the position of the process mark." |
---|
1542 | ;; localize variables not yet localized in `singular-interactive-mode' |
---|
1543 | (make-local-variable 'singular-current-input-section-start) |
---|
1544 | (make-local-variable 'singular-last-input-section-start) |
---|
1545 | |
---|
1546 | ;; initialize markers |
---|
1547 | (if (not (markerp singular-current-input-section-start)) |
---|
1548 | (setq singular-current-input-section-start (make-marker))) |
---|
1549 | (if (not (markerp singular-last-input-section-start)) |
---|
1550 | (setq singular-last-input-section-start (make-marker)))) |
---|
1551 | |
---|
1552 | (defun singular-send-string (process string) |
---|
1553 | "Send newline terminated STRING to to process PROCESS. |
---|
1554 | Runs the hooks on `singular-pre-input-filter-functions' in the buffer |
---|
1555 | associated to PROCESS. The functions get the non-terminated string." |
---|
1556 | (let ((process-buffer (process-buffer process))) |
---|
1557 | |
---|
1558 | ;; check whether buffer is still alive |
---|
1559 | (if (and process-buffer (buffer-name process-buffer)) |
---|
1560 | (save-excursion |
---|
1561 | (set-buffer process-buffer) |
---|
1562 | (send-string |
---|
1563 | process |
---|
1564 | (concat (singular-run-hook-with-arg-and-value |
---|
1565 | singular-pre-input-filter-functions string) |
---|
1566 | "\n")))))) |
---|
1567 | |
---|
1568 | (defun singular-input-filter (process string-or-pos) |
---|
1569 | "Insert/update input from user in buffer associated to PROCESS. |
---|
1570 | Inserts STRING-OR-POS followed by a newline at process mark if it is a |
---|
1571 | string. |
---|
1572 | Assumes that the input is already inserted and that it is placed |
---|
1573 | between process mark and STRING-OR-POS if the latter is a position. |
---|
1574 | Inserts a newline after STRING-OR-POS. |
---|
1575 | |
---|
1576 | Takes care off: |
---|
1577 | - current buffer as well as point and restriction in buffer associated |
---|
1578 | with process, even against non-local exits. |
---|
1579 | Updates: |
---|
1580 | - process mark; |
---|
1581 | - current and last sections; |
---|
1582 | - simple sections; |
---|
1583 | - mode line. |
---|
1584 | |
---|
1585 | Runs the hooks on `singular-pre-input-filter-functions' and |
---|
1586 | `singular-post-input-filter-functions'. |
---|
1587 | |
---|
1588 | For a more detailed descriptions of the input filter, the markers it |
---|
1589 | sets, and input filter functions refer to the section \"Some lengthy |
---|
1590 | notes on input and output\" in singular.el." |
---|
1591 | (let ((process-buffer (process-buffer process))) |
---|
1592 | |
---|
1593 | ;; check whether buffer is still alive |
---|
1594 | (if (and process-buffer (buffer-name process-buffer)) |
---|
1595 | (let ((old-buffer (current-buffer)) |
---|
1596 | (old-pmark (marker-position (process-mark process))) |
---|
1597 | old-point old-point-min old-point-max) |
---|
1598 | (unwind-protect |
---|
1599 | (let (simple-sec-start) |
---|
1600 | (set-buffer process-buffer) |
---|
1601 | ;; the following lines are not protected since the |
---|
1602 | ;; unwind-forms refer the variables being set here |
---|
1603 | (setq old-point (point-marker) |
---|
1604 | old-point-min (point-min-marker) |
---|
1605 | old-point-max (point-max-marker) |
---|
1606 | |
---|
1607 | ;; get end of last simple section (equals start of |
---|
1608 | ;; current) |
---|
1609 | simple-sec-start (marker-position singular-simple-sec-last-end)) |
---|
1610 | |
---|
1611 | ;; prepare for insertion |
---|
1612 | (widen) |
---|
1613 | (set-marker-insertion-type old-point t) |
---|
1614 | (set-marker-insertion-type old-point-max t) |
---|
1615 | |
---|
1616 | ;; insert string at process mark and advance process |
---|
1617 | ;; mark after insertion. If it not a string simply |
---|
1618 | ;; jump to desired position and insrt a newline. |
---|
1619 | (if (stringp string-or-pos) |
---|
1620 | (progn |
---|
1621 | (goto-char old-pmark) |
---|
1622 | (insert string-or-pos)) |
---|
1623 | (goto-char string-or-pos)) |
---|
1624 | (insert ?\n) |
---|
1625 | (set-marker (process-mark process) (point)) |
---|
1626 | |
---|
1627 | ;; create new simple section and update section markers |
---|
1628 | (cond |
---|
1629 | ((eq (singular-simple-sec-create 'input (point)) 'empty) |
---|
1630 | nil) |
---|
1631 | ;; a new simple section has been created ... |
---|
1632 | ((null (marker-position singular-current-input-section-start)) |
---|
1633 | ;; ... and even a new input section has been created! |
---|
1634 | (set-marker singular-current-input-section-start |
---|
1635 | simple-sec-start) |
---|
1636 | (set-marker singular-last-output-section-start |
---|
1637 | singular-current-output-section-start) |
---|
1638 | (set-marker singular-current-output-section-start nil))) |
---|
1639 | |
---|
1640 | ;; run post-output hooks and force mode-line update |
---|
1641 | (run-hook-with-args 'singular-post-input-filter-functions |
---|
1642 | old-pmark (point))) |
---|
1643 | |
---|
1644 | ;; restore buffer, restrictions and point |
---|
1645 | (narrow-to-region old-point-min old-point-max) |
---|
1646 | (set-marker old-point-min nil) |
---|
1647 | (set-marker old-point-max nil) |
---|
1648 | (goto-char old-point) |
---|
1649 | (set-marker old-point nil) |
---|
1650 | (set-buffer old-buffer)))))) |
---|
1651 | |
---|
1652 | (defun singular-get-old-input (get-section) |
---|
1653 | "Retrieve old input. |
---|
1654 | Retrivies from beginning of current section to point if GET-SECTION is |
---|
1655 | non-nil, otherwise on a per-line base." |
---|
1656 | (if get-section |
---|
1657 | ;; get input from input section |
---|
1658 | (let ((section (singular-section-at (point)))) |
---|
1659 | (if (eq (singular-section-type section) 'input) |
---|
1660 | (setq old-input (singular-input-section-to-string section (point))) |
---|
1661 | (error "Not on an input section"))) |
---|
1662 | ;; get input from line |
---|
1663 | (save-excursion |
---|
1664 | (beginning-of-line) |
---|
1665 | (singular-skip-prompt-forward) |
---|
1666 | (let ((old-point (point))) |
---|
1667 | (end-of-line) |
---|
1668 | (buffer-substring old-point (point)))))) |
---|
1669 | |
---|
1670 | (defun singular-send-or-copy-input (send-full-section) |
---|
1671 | "Send input from current buffer to associated process. |
---|
1672 | NOT READY[old input copying, demo mode, |
---|
1673 | eol-on-send, history, SEND-FULL-SECTION]!" |
---|
1674 | (interactive "P") |
---|
1675 | |
---|
1676 | (let ((process (get-buffer-process (current-buffer))) |
---|
1677 | pmark) |
---|
1678 | ;; some checks and initializations |
---|
1679 | (or process (error "Current buffer has no process")) |
---|
1680 | (setq pmark (marker-position (process-mark process))) |
---|
1681 | |
---|
1682 | (cond |
---|
1683 | (;; check for demo mode and show next chunk if necessary |
---|
1684 | (and singular-demo-mode |
---|
1685 | (eq (point) pmark) |
---|
1686 | (eq pmark (point-max))) |
---|
1687 | (singular-demo-show-next-chunk)) |
---|
1688 | |
---|
1689 | (;; get old input |
---|
1690 | (< (point) pmark) |
---|
1691 | (let ((old-input (singular-get-old-input send-full-section))) |
---|
1692 | (goto-char pmark) |
---|
1693 | (insert old-input))) |
---|
1694 | |
---|
1695 | (;; send input from pmark to point after doing history expansion |
---|
1696 | t |
---|
1697 | ;; I don't know if this is the right point to insert the message |
---|
1698 | ;; print message if demo mode is active |
---|
1699 | (and singular-demo-mode |
---|
1700 | singular-demo-print-messages |
---|
1701 | (message "Hit RET to continue demo")) |
---|
1702 | |
---|
1703 | ;; go to desired position |
---|
1704 | (if comint-eol-on-send (end-of-line)) |
---|
1705 | (if send-full-section (goto-char (point-max))) |
---|
1706 | |
---|
1707 | ;; do history expansion |
---|
1708 | (if (eq comint-input-autoexpand 'input) |
---|
1709 | (comint-replace-by-expanded-history t)) |
---|
1710 | (let* ((input (buffer-substring pmark (point)))) |
---|
1711 | |
---|
1712 | ;; insert input into history |
---|
1713 | (if (and (funcall comint-input-filter input) |
---|
1714 | (or (null comint-input-ignoredups) |
---|
1715 | (not (ring-p comint-input-ring)) |
---|
1716 | (ring-empty-p comint-input-ring) |
---|
1717 | (not (string-equal (ring-ref comint-input-ring 0) input)))) |
---|
1718 | (ring-insert comint-input-ring input)) |
---|
1719 | (setq comint-input-ring-index nil) |
---|
1720 | |
---|
1721 | ;; send string to process ... |
---|
1722 | (singular-send-string process input) |
---|
1723 | ;; ... and insert it into buffer ... |
---|
1724 | (singular-input-filter process (point))))))) |
---|
1725 | ;;}}} |
---|
1726 | |
---|
1727 | ;;{{{ Receiving output |
---|
1728 | (defvar singular-pre-output-filter-functions nil |
---|
1729 | "Functions to call before output is inserted into the buffer. |
---|
1730 | These functions get one argument, a string containing the text sent |
---|
1731 | from process. The functions should return either nil or a string. |
---|
1732 | In the latter case the returned string replaces the string sent from |
---|
1733 | process. |
---|
1734 | |
---|
1735 | This is a buffer-local variable, not a buffer-local hook! |
---|
1736 | |
---|
1737 | `singular-run-hook-with-arg-and-value' is used to run the functions in |
---|
1738 | this list.") |
---|
1739 | |
---|
1740 | (defvar singular-post-output-filter-functions nil |
---|
1741 | "Functions to call after output is inserted into the buffer. |
---|
1742 | These functions get three arguments BEG, END, and SIMPLE-SEC-START. |
---|
1743 | The region between BEG and END is what has been inserted into the |
---|
1744 | buffer. |
---|
1745 | SIMPLE-SEC-START is the start of the simple section which has been |
---|
1746 | created on insertion or nil if no simple section has been created. |
---|
1747 | The functions may assume that no narrowing is in effect and may change |
---|
1748 | point at will. |
---|
1749 | |
---|
1750 | This hook is buffer-local.") |
---|
1751 | |
---|
1752 | (defvar singular-current-output-section-start nil |
---|
1753 | "Marker to the start of the current output section. |
---|
1754 | This marker points nowhere on startup or if there is no current output |
---|
1755 | section. |
---|
1756 | |
---|
1757 | This variable is buffer-local.") |
---|
1758 | |
---|
1759 | (defvar singular-last-output-section-start nil |
---|
1760 | "Marker to the start of the last output section. |
---|
1761 | This marker points nowhere on startup. |
---|
1762 | |
---|
1763 | This variable is buffer-local.") |
---|
1764 | |
---|
1765 | (defun singular-output-filter-init (pos) |
---|
1766 | "Initialize all variables concerning output including process mark. |
---|
1767 | Set process mark to POS." |
---|
1768 | |
---|
1769 | ;; localize variables not yet localized in `singular-interactive-mode' |
---|
1770 | (make-local-variable 'singular-current-output-section-start) |
---|
1771 | (make-local-variable 'singular-last-output-section-start) |
---|
1772 | |
---|
1773 | ;; initialize markers |
---|
1774 | (if (not (markerp singular-current-output-section-start)) |
---|
1775 | (setq singular-current-output-section-start (make-marker))) |
---|
1776 | (if (not (markerp singular-last-output-section-start)) |
---|
1777 | (setq singular-last-output-section-start (make-marker))) |
---|
1778 | (set-marker (singular-process-mark) pos)) |
---|
1779 | |
---|
1780 | (defun singular-output-filter (process string) |
---|
1781 | "Insert STRING containing output from PROCESS into its associated buffer. |
---|
1782 | Takes care off: |
---|
1783 | - current buffer as well as point and restriction in buffer associated |
---|
1784 | with process, even against non-local exits. |
---|
1785 | Updates: |
---|
1786 | - process mark; |
---|
1787 | - current and last sections; |
---|
1788 | - simple sections; |
---|
1789 | - mode line. |
---|
1790 | Runs the hooks on `singular-pre-output-filter-functions' and |
---|
1791 | `singular-post-output-filter-functions'. |
---|
1792 | |
---|
1793 | For a more detailed descriptions of the output filter, the markers it |
---|
1794 | sets, and output filter functions refer to the section \"Some lengthy |
---|
1795 | notes on input and output\" in singular.el." |
---|
1796 | (let ((process-buffer (process-buffer process))) |
---|
1797 | |
---|
1798 | ;; check whether buffer is still alive |
---|
1799 | (if (and process-buffer (buffer-name process-buffer)) |
---|
1800 | (let ((old-buffer (current-buffer)) |
---|
1801 | (old-pmark (marker-position (process-mark process))) |
---|
1802 | old-point old-point-min old-point-max) |
---|
1803 | (unwind-protect |
---|
1804 | (let (simple-sec-start) |
---|
1805 | (set-buffer process-buffer) |
---|
1806 | ;; the following lines are not protected since the |
---|
1807 | ;; unwind-forms refer the variables being set here |
---|
1808 | (setq old-point (point-marker) |
---|
1809 | old-point-min (point-min-marker) |
---|
1810 | old-point-max (point-max-marker) |
---|
1811 | |
---|
1812 | ;; get end of last simple section (equals start of |
---|
1813 | ;; current) |
---|
1814 | simple-sec-start (marker-position singular-simple-sec-last-end) |
---|
1815 | |
---|
1816 | ;; get string to insert |
---|
1817 | string (singular-run-hook-with-arg-and-value |
---|
1818 | singular-pre-output-filter-functions |
---|
1819 | string)) |
---|
1820 | |
---|
1821 | ;; prepare for insertion |
---|
1822 | (widen) |
---|
1823 | (set-marker-insertion-type old-point t) |
---|
1824 | (set-marker-insertion-type old-point-max t) |
---|
1825 | |
---|
1826 | ;; insert string at process mark and advance process |
---|
1827 | ;; mark after insertion |
---|
1828 | (goto-char old-pmark) |
---|
1829 | (insert string) |
---|
1830 | (set-marker (process-mark process) (point)) |
---|
1831 | |
---|
1832 | ;; create new simple section and update section markers |
---|
1833 | (cond |
---|
1834 | ((eq (singular-simple-sec-create 'output (point)) 'empty) |
---|
1835 | (setq simple-sec-start nil)) |
---|
1836 | ;; a new simple section has been created ... |
---|
1837 | ((null (marker-position singular-current-output-section-start)) |
---|
1838 | ;; ... and even a new output section has been created! |
---|
1839 | (set-marker singular-current-output-section-start |
---|
1840 | simple-sec-start) |
---|
1841 | (set-marker singular-last-input-section-start |
---|
1842 | singular-current-input-section-start) |
---|
1843 | (set-marker singular-current-input-section-start nil))) |
---|
1844 | |
---|
1845 | ;; run post-output hooks and force mode-line update |
---|
1846 | (run-hook-with-args 'singular-post-output-filter-functions |
---|
1847 | old-pmark (point) simple-sec-start) |
---|
1848 | (force-mode-line-update)) |
---|
1849 | |
---|
1850 | ;; restore buffer, restrictions and point |
---|
1851 | (narrow-to-region old-point-min old-point-max) |
---|
1852 | (set-marker old-point-min nil) |
---|
1853 | (set-marker old-point-max nil) |
---|
1854 | (goto-char old-point) |
---|
1855 | (set-marker old-point nil) |
---|
1856 | (set-buffer old-buffer)))))) |
---|
1857 | ;;}}} |
---|
1858 | |
---|
1859 | ;;{{{ Singular interactive mode |
---|
1860 | (defun singular-interactive-mode () |
---|
1861 | "Major mode for interacting with Singular. |
---|
1862 | |
---|
1863 | NOT READY [how to send input]! |
---|
1864 | |
---|
1865 | NOT READY [multiple Singulars]! |
---|
1866 | |
---|
1867 | \\{singular-interactive-mode-map} |
---|
1868 | Customization: Entry to this mode runs the hooks on `comint-mode-hook' |
---|
1869 | and `singular-interactive-mode-hook' \(in that order). Before each |
---|
1870 | input, the hooks on `comint-input-filter-functions' are run. After |
---|
1871 | each Singular output, the hooks on `comint-output-filter-functions' |
---|
1872 | are run. |
---|
1873 | |
---|
1874 | NOT READY [much more to come. See shell.el.]!" |
---|
1875 | (interactive) |
---|
1876 | |
---|
1877 | ;; remove existing singular-start-menu from menu (XEmacs) |
---|
1878 | ;, NOT READY |
---|
1879 | ;; This is mayby just temporary |
---|
1880 | ; (cond |
---|
1881 | ; ;; XEmacs |
---|
1882 | ; ((eq singular-emacs-flavor 'xemacs) |
---|
1883 | ; (delete-menu-item '("Singular")))) |
---|
1884 | |
---|
1885 | ;; run comint mode and do basic mode setup |
---|
1886 | (comint-mode) |
---|
1887 | (setq major-mode 'singular-interactive-mode) |
---|
1888 | (setq mode-name "Singular Interaction") |
---|
1889 | |
---|
1890 | ;; key bindings, syntax tables and menus |
---|
1891 | (use-local-map singular-interactive-mode-map) |
---|
1892 | (set-syntax-table singular-interactive-mode-syntax-table) |
---|
1893 | (cond |
---|
1894 | ;; XEmacs |
---|
1895 | ((eq singular-emacs-flavor 'xemacs) |
---|
1896 | (easy-menu-add singular-interactive-mode-menu-1) |
---|
1897 | (easy-menu-add singular-interactive-mode-menu-2))) |
---|
1898 | |
---|
1899 | (setq comment-start "// ") |
---|
1900 | (setq comment-start-skip "// *") |
---|
1901 | (setq comment-end "") |
---|
1902 | |
---|
1903 | ;; customize comint for Singular |
---|
1904 | (setq comint-prompt-regexp singular-prompt-regexp) |
---|
1905 | (setq comint-delimiter-argument-list singular-delimiter-argument-list) |
---|
1906 | (setq comint-input-ignoredups singular-input-ignoredups) |
---|
1907 | (make-local-variable 'comint-buffer-maximum-size) |
---|
1908 | (setq comint-buffer-maximum-size singular-buffer-maximum-size) |
---|
1909 | (setq comint-input-ring-size singular-input-ring-size) |
---|
1910 | (setq comint-input-filter singular-history-filter) |
---|
1911 | |
---|
1912 | ;; get name of history file (if any) |
---|
1913 | (setq comint-input-ring-file-name (getenv "SINGULARHIST")) |
---|
1914 | (if (or (not comint-input-ring-file-name) |
---|
1915 | (equal comint-input-ring-file-name "") |
---|
1916 | (equal (file-truename comint-input-ring-file-name) "/dev/null")) |
---|
1917 | (setq comint-input-ring-file-name nil)) |
---|
1918 | |
---|
1919 | ;; initialize singular demo mode, input and output filters |
---|
1920 | (singular-demo-mode 'init) |
---|
1921 | (make-local-variable 'singular-pre-input-filter-functions) |
---|
1922 | (make-local-hook 'singular-post-input-filter-functions) |
---|
1923 | (make-local-variable 'singular-pre-output-filter-functions) |
---|
1924 | (make-local-hook 'singular-post-output-filter-functions) |
---|
1925 | |
---|
1926 | ;; selective display |
---|
1927 | (setq selective-display t) |
---|
1928 | (setq selective-display-ellipses t) |
---|
1929 | (cond |
---|
1930 | ;; Emacs |
---|
1931 | ((eq singular-emacs-flavor 'emacs) |
---|
1932 | (setq buffer-display-table (or (copy-sequence standard-display-table) |
---|
1933 | (make-display-table))) |
---|
1934 | (set-display-table-slot buffer-display-table |
---|
1935 | 'selective-display (vconcat singular-folding-ellipsis))) |
---|
1936 | ;; XEmacs |
---|
1937 | (t |
---|
1938 | (set-glyph-image invisible-text-glyph singular-folding-ellipsis (current-buffer)))) |
---|
1939 | |
---|
1940 | ;; debugging filters |
---|
1941 | (singular-debug 'interactive-filter |
---|
1942 | (add-hook 'singular-pre-input-filter-functions |
---|
1943 | 'singular-debug-pre-input-filter nil t)) |
---|
1944 | (singular-debug 'interactive-filter |
---|
1945 | (add-hook 'singular-post-input-filter-functions |
---|
1946 | 'singular-debug-post-input-filter nil t)) |
---|
1947 | (singular-debug 'interactive-filter |
---|
1948 | (add-hook 'singular-pre-output-filter-functions |
---|
1949 | 'singular-debug-pre-output-filter nil t)) |
---|
1950 | (singular-debug 'interactive-filter |
---|
1951 | (add-hook 'singular-post-output-filter-functions |
---|
1952 | 'singular-debug-post-output-filter nil t)) |
---|
1953 | |
---|
1954 | ;; other input or output filters |
---|
1955 | (add-hook 'singular-post-output-filter-functions |
---|
1956 | 'singular-remove-prompt-filter nil t) |
---|
1957 | |
---|
1958 | ;; font-locking |
---|
1959 | (cond |
---|
1960 | ;; Emacs |
---|
1961 | ((eq singular-emacs-flavor 'emacs) |
---|
1962 | (make-local-variable 'font-lock-defaults) |
---|
1963 | (singular-debug 'interactive (message "Setting up font-lock for emacs")) |
---|
1964 | (setq font-lock-defaults singular-font-lock-defaults))) |
---|
1965 | |
---|
1966 | (run-hooks 'singular-interactive-mode-hook)) |
---|
1967 | ;;}}} |
---|
1968 | |
---|
1969 | ;;{{{ Starting singular |
---|
1970 | (defvar singular-start-file "~/.emacs_singularrc" |
---|
1971 | "Name of start-up file to pass to Singular. |
---|
1972 | If the file named by this variable exists it is given as initial input |
---|
1973 | to any Singular process being started. Note that this may lose due to |
---|
1974 | a timing error if Singular discards input when it starts up.") |
---|
1975 | |
---|
1976 | (defvar singular-default-executable "Singular" |
---|
1977 | "Default name of Singular executable. |
---|
1978 | Used by `singular' when new Singular processes are started.") |
---|
1979 | |
---|
1980 | (defvar singular-default-name "singular" |
---|
1981 | "Default process name for Singular process. |
---|
1982 | Used by `singular' when new Singular processes are started.") |
---|
1983 | |
---|
1984 | (defvar singular-default-switches '("-t") |
---|
1985 | "Default switches for Singular processes. |
---|
1986 | Used by `singular' when new Singular processes are started.") |
---|
1987 | |
---|
1988 | (defun singular-exit-sentinel (process message) |
---|
1989 | "Clean up after termination of Singular. |
---|
1990 | Writes back input ring after regular termination of Singular if |
---|
1991 | process buffer is still alive." |
---|
1992 | (save-excursion |
---|
1993 | (singular-debug 'interactive |
---|
1994 | (message "Sentinel: %s" (substring message 0 -1))) |
---|
1995 | ;; exit demo mode if necessary |
---|
1996 | (singular-demo-mode 'exit) |
---|
1997 | (if (string-match "finished\\|exited" message) |
---|
1998 | (let ((process-buffer (process-buffer process))) |
---|
1999 | (if (and process-buffer |
---|
2000 | (buffer-name process-buffer) |
---|
2001 | (set-buffer process-buffer)) |
---|
2002 | (progn |
---|
2003 | (singular-debug 'interactive (message "Writing input ring back")) |
---|
2004 | (comint-write-input-ring))))))) |
---|
2005 | |
---|
2006 | (defun singular-exec (buffer name executable start-file switches) |
---|
2007 | "Start a new Singular process NAME in BUFFER, running EXECUTABLE. |
---|
2008 | EXECUTABLE should be a string denoting an executable program. |
---|
2009 | SWITCHES should be a list of strings that are passed as command line |
---|
2010 | switches. START-FILE should be the name of a file which contents is |
---|
2011 | sent to the process. |
---|
2012 | |
---|
2013 | Deletes any old processes running in that buffer. |
---|
2014 | Moves point to the end of BUFFER. |
---|
2015 | Initializes all important markers and the simple sections. |
---|
2016 | Runs `comint-exec-hook' and `singular-exec-hook' (in that order). |
---|
2017 | Returns BUFFER." |
---|
2018 | (let ((old-buffer (current-buffer))) |
---|
2019 | (unwind-protect |
---|
2020 | (progn |
---|
2021 | (set-buffer buffer) |
---|
2022 | |
---|
2023 | ;; delete any old processes |
---|
2024 | (let ((process (get-buffer-process buffer))) |
---|
2025 | (if process (delete-process process))) |
---|
2026 | |
---|
2027 | ;; create new process |
---|
2028 | (singular-debug 'interactive (message "Starting new Singular")) |
---|
2029 | (let ((process (comint-exec-1 name buffer executable switches))) |
---|
2030 | |
---|
2031 | ;; set process filter and sentinel |
---|
2032 | (set-process-filter process 'singular-output-filter) |
---|
2033 | (set-process-sentinel process 'singular-exit-sentinel) |
---|
2034 | (make-local-variable 'comint-ptyp) |
---|
2035 | (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. |
---|
2036 | |
---|
2037 | ;; go to the end of the buffer, initialize I/O and simple |
---|
2038 | ;; sections |
---|
2039 | (goto-char (point-max)) |
---|
2040 | (singular-input-filter-init (point)) |
---|
2041 | (singular-output-filter-init (point)) |
---|
2042 | (singular-simple-sec-init (point)) |
---|
2043 | |
---|
2044 | ;; NOT READY: SINGULAR-LOGO |
---|
2045 | ; (cond |
---|
2046 | ; ((eq singular-emacs-flavor 'xemacs) |
---|
2047 | ; (set-extent-begin-glyph (make-extent (point-min) (point-min)) |
---|
2048 | ; singular-logo) |
---|
2049 | ; (insert "\n"))) |
---|
2050 | |
---|
2051 | ;; feed process with start file and read input ring. Take |
---|
2052 | ;; care about the undo information. |
---|
2053 | (if start-file |
---|
2054 | (let ((buffer-undo-list t) start-string) |
---|
2055 | (singular-debug 'interactive (message "Feeding start file")) |
---|
2056 | (sleep-for 1) ; try to avoid timing errors |
---|
2057 | (insert-file-contents start-file) |
---|
2058 | (setq start-string (buffer-substring (point) (point-max))) |
---|
2059 | (delete-region (point) (point-max)) |
---|
2060 | (send-string process start-string))) |
---|
2061 | (singular-debug 'interactive (message "Reading input ring")) |
---|
2062 | (comint-read-input-ring t) |
---|
2063 | |
---|
2064 | ;; execute hooks |
---|
2065 | (run-hooks 'comint-exec-hook) |
---|
2066 | (run-hooks 'singular-exec-hook)) |
---|
2067 | |
---|
2068 | buffer) |
---|
2069 | ;; this code is unwide-protected |
---|
2070 | (set-buffer old-buffer)))) |
---|
2071 | |
---|
2072 | ;; NOT READY: SINGULAR-LOGO |
---|
2073 | ;(cond |
---|
2074 | ; ((eq singular-emacs-flavor 'xemacs) |
---|
2075 | ; (defvar singular-logo (make-glyph)) |
---|
2076 | ; (set-glyph-image singular-logo |
---|
2077 | ; (concat "~/" "singlogo.xpm") |
---|
2078 | ; 'global 'x))) |
---|
2079 | |
---|
2080 | ;; Note: |
---|
2081 | ;; |
---|
2082 | ;; In contrast to shell.el, `singular' does not run |
---|
2083 | ;; `singular-interactive-mode' every time a new Singular process is |
---|
2084 | ;; started, but only when a new buffer is created. This behaviour seems |
---|
2085 | ;; more intuitive w.r.t. local variables and hooks. |
---|
2086 | |
---|
2087 | (defun singular (&optional executable name switches) |
---|
2088 | "Run an inferior Singular process, with I/O through an Emacs buffer. |
---|
2089 | |
---|
2090 | NOT READY [arguments, default values, and interactive use]! |
---|
2091 | |
---|
2092 | If buffer exists but Singular is not running, starts new Singular. |
---|
2093 | If buffer exists and Singular is running, just switches to buffer. |
---|
2094 | If a file `~/.emacs_singularrc' exists, it is given as initial input. |
---|
2095 | Note that this may lose due to a timing error if Singular discards |
---|
2096 | input when it starts up. |
---|
2097 | |
---|
2098 | If a new buffer is created it is put in Singular interactive mode, |
---|
2099 | giving commands for sending input and handling ouput of Singular. See |
---|
2100 | `singular-interactive-mode'. |
---|
2101 | |
---|
2102 | Every time `singular' starts a new Singular process it runs the hooks |
---|
2103 | on `comint-exec-hook' and `singular-exec-hook' \(in that order). |
---|
2104 | |
---|
2105 | Type \\[describe-mode] in the Singular buffer for a list of commands." |
---|
2106 | ;; handle interactive calls |
---|
2107 | (interactive (list singular-default-executable |
---|
2108 | singular-default-name |
---|
2109 | singular-default-switches)) |
---|
2110 | |
---|
2111 | (let* (;; get default values for optional arguments |
---|
2112 | (executable (or executable singular-default-executable)) |
---|
2113 | (name (or name singular-default-name)) |
---|
2114 | (switches (or switches singular-default-switches)) |
---|
2115 | |
---|
2116 | (buffer-name (singular-process-name-to-buffer-name name)) |
---|
2117 | ;; buffer associated with Singular, nil if there is none |
---|
2118 | (buffer (get-buffer buffer-name))) |
---|
2119 | |
---|
2120 | (if (not buffer) |
---|
2121 | (progn |
---|
2122 | ;; create new buffer and call `singular-interactive-mode' |
---|
2123 | (singular-debug 'interactive (message "Creating new buffer")) |
---|
2124 | (setq buffer (get-buffer-create buffer-name)) |
---|
2125 | (set-buffer buffer) |
---|
2126 | |
---|
2127 | (singular-debug 'interactive (message "Calling `singular-interactive-mode'")) |
---|
2128 | (singular-interactive-mode))) |
---|
2129 | |
---|
2130 | (if (not (comint-check-proc buffer)) |
---|
2131 | ;; create new process if there is none |
---|
2132 | (singular-exec buffer name executable |
---|
2133 | (if (file-exists-p singular-start-file) |
---|
2134 | singular-start-file) |
---|
2135 | switches)) |
---|
2136 | |
---|
2137 | ;; pop to buffer |
---|
2138 | (singular-debug 'interactive (message "Calling `pop-to-buffer'")) |
---|
2139 | (pop-to-buffer buffer))) |
---|
2140 | |
---|
2141 | ;; for convenience only |
---|
2142 | (defalias 'Singular 'singular) |
---|
2143 | |
---|
2144 | (defun singular-generate-new-buffer-name (name) |
---|
2145 | "Generate a unique buffer name for a singular interactive buffer. |
---|
2146 | The string NAME is the desired name for the singular interactive |
---|
2147 | buffer, without surrounding stars. |
---|
2148 | The string returned is surrounded by stars. |
---|
2149 | |
---|
2150 | If no buffer with name \"*NAME*\" exists, return \"*NAME*\". |
---|
2151 | Otherwise check for buffer called \"*NAME<n>*\" where n is a |
---|
2152 | increasing number and return \"*NAME<n>*\" if no such buffer |
---|
2153 | exists." |
---|
2154 | (let ((new-name (singular-process-name-to-buffer-name name)) |
---|
2155 | (count 2)) |
---|
2156 | (while (get-buffer new-name) |
---|
2157 | (setq new-name (singular-process-name-to-buffer-name |
---|
2158 | (concat name "<" (format "%d" count) ">"))) |
---|
2159 | (setq count (1+ count))) |
---|
2160 | new-name)) |
---|
2161 | |
---|
2162 | (defun singular-other (file) |
---|
2163 | "Start a new Singular, different to the default Singular. |
---|
2164 | FILE is a Singular executable. |
---|
2165 | |
---|
2166 | Asks in the minibuffer for a buffer-name and for Singular options. |
---|
2167 | Calls `singular' with the appropriate arguments." |
---|
2168 | (interactive "fSingular executable: ") |
---|
2169 | ;; NOT READY [code] |
---|
2170 | (let ((name (singular-generate-new-buffer-name |
---|
2171 | (downcase (file-name-nondirectory file)))) |
---|
2172 | (switches "") |
---|
2173 | temp) |
---|
2174 | |
---|
2175 | ;; Read buffer name from minibuffer at strip surrounding stars |
---|
2176 | ;; NOT READY: This code is not very beautyful. |
---|
2177 | (let ((buffer-exists t) |
---|
2178 | (new-name name)) |
---|
2179 | (while buffer-exists |
---|
2180 | (setq new-name (read-from-minibuffer "Singular buffer name: " name)) |
---|
2181 | (if (get-buffer new-name) |
---|
2182 | (progn |
---|
2183 | (message "This buffer already exists.") |
---|
2184 | (sleep-for 1)) |
---|
2185 | (setq buffer-exists nil) |
---|
2186 | (setq name new-name)))) |
---|
2187 | |
---|
2188 | |
---|
2189 | (if (string-match "^\\*\\(.*\\)\\*$" name) |
---|
2190 | (setq name (substring name (match-beginning 1) (match-end 1)))) |
---|
2191 | |
---|
2192 | ;; make one string of options from list of default options |
---|
2193 | (setq temp singular-default-switches) |
---|
2194 | (while temp |
---|
2195 | (setq switches (concat switches (car temp) " ")) |
---|
2196 | (setq temp (cdr temp))) |
---|
2197 | ;; in minibuffer omit display of option "-t " |
---|
2198 | (setq switches (read-from-minibuffer "Singular options: " |
---|
2199 | (replace-in-string switches "-t " ""))) |
---|
2200 | |
---|
2201 | ;; make list of strings of switch-string |
---|
2202 | (setq temp '("-t")) |
---|
2203 | (while (string-match "-[^ ]*" switches) |
---|
2204 | (setq temp (append temp (list (substring switches (match-beginning 0) |
---|
2205 | (match-end 0))))) |
---|
2206 | (setq switches (substring switches (match-end 0) nil))) |
---|
2207 | (setq switches temp) |
---|
2208 | |
---|
2209 | (singular file name switches))) |
---|
2210 | ;;}}} |
---|
2211 | ;;}}} |
---|
2212 | |
---|
2213 | (provide 'singular) |
---|
2214 | |
---|
2215 | ;;; singular.el ends here. |
---|