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