[Nuke cruft clinton@unknownlamer.org**20100809053902 Ignore-this: 11a8c0a8a34f01efcf2f569f5a479d51 ] { hunk ./init.d/goodies.el 1 -;;; Emacs Goodies hunk ./init.d/goodies.el 2 -;; Grab local copy of htmlize which is newer and has features I need -;; to use for my muse extensions before pushing the goodies path onto -;; the load-path -(require 'htmlize) - -(add-to-list 'load-path (expand-file-name - "/usr/share/emacs/site-lisp/emacs-goodies-el")) - -(require 'bar-cursor) -(bar-cursor-mode 1) -(iswitchb-mode) rmfile ./init.d/goodies.el hunk ./init.d/misc.el 108 + +(require 'htmlize) +(require 'bar-cursor) + +(bar-cursor-mode 1) +(iswitchb-mode) hunk ./init.d/thumbs.el 1 -(if window-system - (require 'thumbs)) rmfile ./init.d/thumbs.el hunk ./init.d/w3m.el 11 - -;;; Sessions -(require 'w3m-session) - -(setq w3m-session-load-always t) -(setq w3m-session-save-always t) - -(add-hook 'midnight-hook #'w3m-session-save) hunk ./site-lisp/gds-scheme.el 1 -;;; gds-scheme.el -- GDS function for Scheme mode buffers - -;;;; Copyright (C) 2005 Neil Jerram -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later -;;;; version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free -;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;;; 02111-1307 USA - -(require 'comint) -(require 'scheme) -(require 'derived) -(require 'pp) - -;;;; Maintaining an association between a Guile client process and a -;;;; set of Scheme mode buffers. - -(defcustom gds-auto-create-utility-client t - "Whether to automatically create a utility Guile client, and -associate the current buffer with it, if there are no existing Guile -clients available to GDS when the user does something that requires a -running Guile client." - :type 'boolean - :group 'gds) - -(defcustom gds-auto-associate-single-client t - "Whether to automatically associate the current buffer with an -existing Guile client, if there is only only client known to GDS when -the user does something that requires a running Guile client, and the -current buffer is not already associated with a Guile client." - :type 'boolean - :group 'gds) - -(defcustom gds-auto-associate-last-client t - "Whether to automatically associate the current buffer with the -Guile client that most recently caused that buffer to be displayed, -when the user does something that requires a running Guile client and -the current buffer is not already associated with a Guile client." - :type 'boolean - :group 'gds) - -(defvar gds-last-touched-by nil - "For each Scheme mode buffer, this records the GDS client that most -recently `touched' that buffer in the sense of using it to display -source code, for example for the source code relevant to a debugger -stack frame.") -(make-variable-buffer-local 'gds-last-touched-by) - -(defun gds-auto-associate-buffer () - "Automatically associate the current buffer with a Guile client, if -possible." - (let* ((num-clients (length gds-client-info)) - (client - (or - ;; If there are no clients yet, and - ;; `gds-auto-create-utility-client' allows us to create one - ;; automatically, do that. - (and (= num-clients 0) - gds-auto-create-utility-client - (gds-start-utility-guile)) - ;; Otherwise, if there is a single existing client, and - ;; `gds-auto-associate-single-client' allows us to use it - ;; for automatic association, do that. - (and (= num-clients 1) - gds-auto-associate-single-client - (caar gds-client-info)) - ;; Otherwise, if the current buffer was displayed because - ;; of a Guile client trapping somewhere in its code, and - ;; `gds-auto-associate-last-client' allows us to associate - ;; with that client, do so. - (and gds-auto-associate-last-client - gds-last-touched-by)))) - (if client - (gds-associate-buffer client)))) - -(defun gds-associate-buffer (client) - "Associate the current buffer with the Guile process CLIENT. -This means that operations in this buffer that require a running Guile -process - such as evaluation, help, completion and setting traps - -will be sent to the Guile process whose name or connection number is -CLIENT." - (interactive (list (gds-choose-client))) - ;; If this buffer is already associated, dissociate from its - ;; existing client first. - (if gds-client (gds-dissociate-buffer)) - ;; Store the client number in the buffer-local variable gds-client. - (setq gds-client client) - ;; Add this buffer to the list of buffers associated with the - ;; client. - (gds-client-put client 'associated-buffers - (cons (current-buffer) - (gds-client-get client 'associated-buffers)))) - -(defun gds-dissociate-buffer () - "Dissociate the current buffer from any specific Guile process." - (interactive) - (if gds-client - (progn - ;; Remove this buffer from the list of buffers associated with - ;; the current client. - (gds-client-put gds-client 'associated-buffers - (delq (current-buffer) - (gds-client-get gds-client 'associated-buffers))) - ;; Reset the buffer-local variable gds-client. - (setq gds-client nil) - ;; Clear any process status indication from the modeline. - (setq mode-line-process nil) - (force-mode-line-update)))) - -(defun gds-show-client-status (client status-string) - "Show a client's status in the modeline of all its associated -buffers." - (let ((buffers (gds-client-get client 'associated-buffers))) - (while buffers - (if (buffer-live-p (car buffers)) - (with-current-buffer (car buffers) - (setq mode-line-process status-string) - (force-mode-line-update))) - (setq buffers (cdr buffers))))) - -(defcustom gds-running-text ":running" - "*Mode line text used to show that a Guile process is \"running\". -\"Running\" means that the process cannot currently accept any input -from the GDS frontend in Emacs, because all of its threads are busy -running code that GDS cannot easily interrupt." - :type 'string - :group 'gds) - -(defcustom gds-ready-text ":ready" - "*Mode line text used to show that a Guile process is \"ready\". -\"Ready\" means that the process is ready to interact with the GDS -frontend in Emacs, because at least one of its threads is waiting for -GDS input." - :type 'string - :group 'gds) - -(defcustom gds-debug-text ":debug" - "*Mode line text used to show that a Guile process is \"debugging\". -\"Debugging\" means that the process is using the GDS frontend in -Emacs to display an error or trap so that the user can debug it." - :type 'string - :group 'gds) - -(defun gds-choose-client () - "Ask the user to choose a GDS client process from a list." - (let ((table '()) - (default nil)) - ;; Prepare a table containing all current clients. - (mapcar (lambda (client-info) - (setq table (cons (cons (cadr (memq 'name client-info)) - (car client-info)) - table))) - gds-client-info) - ;; Add an entry to allow the user to ask for a new process. - (setq table (cons (cons "Start a new Guile process" nil) table)) - ;; Work out a good default. If the buffer has a good value in - ;; gds-last-touched-by, we use that; otherwise default to starting - ;; a new process. - (setq default (or (and gds-last-touched-by - (gds-client-get gds-last-touched-by 'name)) - (caar table))) - ;; Read using this table. - (let* ((name (completing-read "Choose a Guile process: " - table - nil - t ; REQUIRE-MATCH - nil ; INITIAL-INPUT - nil ; HIST - default)) - ;; Convert name to a client number. - (client (cdr (assoc name table)))) - ;; If the user asked to start a new Guile process, do that now. - (or client (setq client (gds-start-utility-guile))) - ;; Return the chosen client ID. - client))) - -(defvar gds-last-utility-number 0 - "Number of the last started Guile utility process.") - -(defun gds-start-utility-guile () - "Start a new utility Guile process." - (setq gds-last-utility-number (+ gds-last-utility-number 1)) - (let* ((procname (format "gds-util[%d]" gds-last-utility-number)) - (code (format "(begin - %s - (use-modules (ice-9 gds-client)) - (run-utility))" - (if gds-scheme-directory - (concat "(set! %load-path (cons " - (format "%S" gds-scheme-directory) - " %load-path))") - ""))) - (proc (start-process procname - (get-buffer-create procname) - gds-guile-program - "-q" - "--debug" - "-c" - code)) - (client nil)) - ;; Note that this process can be killed automatically on Emacs - ;; exit. - (process-kill-without-query proc) - ;; Set up a process filter to catch the new client's number. - (set-process-filter proc - (lambda (proc string) - (setq client (string-to-number string)) - (if (process-buffer proc) - (with-current-buffer (process-buffer proc) - (insert string))))) - ;; Accept output from the new process until we have its number. - (while (not client) - (accept-process-output proc)) - ;; Return the new process's client number. - client)) - -;;;; Evaluating code. - -;; The following commands send code for evaluation through the GDS TCP -;; connection, receive the result and any output generated through the -;; same connection, and display the result and output to the user. -;; -;; For each buffer where evaluations can be requested, GDS uses the -;; buffer-local variable `gds-client' to track which GDS client -;; program should receive and handle that buffer's evaluations. - -(defun gds-module-name (start end) - "Determine and return the name of the module that governs the -specified region. The module name is returned as a list of symbols." - (interactive "r") ; why not? - (save-excursion - (goto-char start) - (let (module-name) - (while (and (not module-name) - (beginning-of-defun-raw 1)) - (if (looking-at "(define-module ") - (setq module-name - (progn - (goto-char (match-end 0)) - (read (current-buffer)))))) - module-name))) - -(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: " - "Prefix used when telling Guile the name of the port from which a -chunk of Scheme code (to be evaluated) comes. GDS uses this prefix, -followed by the buffer name, in two cases: when the buffer concerned -is not associated with a file, or if the buffer has been modified -since last saving to its file. In the case where the buffer is -identical to a saved file, GDS uses the file name as the port name." - :type '(string) - :group 'gds) - -(defun gds-port-name (start end) - "Return port name for the specified region of the current buffer. -The name will be used by Guile as the port name when evaluating that -region's code." - (or (and (not (buffer-modified-p)) - buffer-file-name) - (concat gds-emacs-buffer-port-name-prefix (buffer-name)))) - -(defun gds-line-and-column (pos) - "Return 0-based line and column number at POS." - (let (line column) - (save-excursion - (goto-char pos) - (setq column (current-column)) - (beginning-of-line) - (setq line (count-lines (point-min) (point)))) - (cons line column))) - -(defun gds-eval-region (start end) - "Evaluate the current region." - (interactive "r") - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (let ((module (gds-module-name start end)) - (port-name (gds-port-name start end)) - (lc (gds-line-and-column start))) - (let ((code (buffer-substring-no-properties start end))) - (gds-send (format "eval (region . %S) %s %S %d %d %S" - (gds-abbreviated code) - (if module (prin1-to-string module) "#f") - port-name (car lc) (cdr lc) - code) - gds-client)))) - -(defun gds-eval-expression (expr &optional correlator) - "Evaluate the supplied EXPR (a string)." - (interactive "sEvaluate expression: \nP") - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (set-text-properties 0 (length expr) nil expr) - (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S" - (or correlator 'expression) - (gds-abbreviated expr) - expr) - gds-client)) - -(defconst gds-abbreviated-length 35) - -(defun gds-abbreviated (code) - (let ((nlpos (string-match (regexp-quote "\n") code))) - (while nlpos - (setq code - (if (= nlpos (- (length code) 1)) - (substring code 0 nlpos) - (concat (substring code 0 nlpos) - "\\n" - (substring code (+ nlpos 1))))) - (setq nlpos (string-match (regexp-quote "\n") code)))) - (if (> (length code) gds-abbreviated-length) - (concat (substring code 0 (- gds-abbreviated-length 3)) "...") - code)) - -(defun gds-eval-defun () - "Evaluate the defun (top-level form) at point." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (gds-eval-region (point) end)))) - -(defun gds-eval-last-sexp () - "Evaluate the sexp before point." - (interactive) - (gds-eval-region (save-excursion (backward-sexp) (point)) (point))) - -;;;; Help. - -;; Help is implemented as a special case of evaluation, identified by -;; the evaluation correlator 'help. - -(defun gds-help-symbol (sym) - "Get help for SYM (a Scheme symbol)." - (interactive - (let ((sym (thing-at-point 'symbol)) - (enable-recursive-minibuffers t) - val) - (setq val (read-from-minibuffer - (if sym - (format "Describe Guile symbol (default %s): " sym) - "Describe Guile symbol: "))) - (list (if (zerop (length val)) sym val)))) - (gds-eval-expression (format "(help %s)" sym) 'help)) - -(defun gds-apropos (regex) - "List Guile symbols matching REGEX." - (interactive - (let ((sym (thing-at-point 'symbol)) - (enable-recursive-minibuffers t) - val) - (setq val (read-from-minibuffer - (if sym - (format "Guile apropos (regexp, default \"%s\"): " sym) - "Guile apropos (regexp): "))) - (list (if (zerop (length val)) sym val)))) - (set-text-properties 0 (length regex) nil regex) - (gds-eval-expression (format "(apropos %S)" regex) 'apropos)) - -;;;; Displaying results of help and eval. - -(defun gds-display-results (client correlator stack-available results) - (let* ((helpp+bufname (cond ((eq (car correlator) 'help) - '(t . "*Guile Help*")) - ((eq (car correlator) 'apropos) - '(t . "*Guile Apropos*")) - (t - '(nil . "*Guile Evaluation*")))) - (helpp (car helpp+bufname))) - (let ((buf (get-buffer-create (cdr helpp+bufname)))) - (save-selected-window - (save-excursion - (set-buffer buf) - (gds-dissociate-buffer) - (erase-buffer) - (scheme-mode) - (insert (cdr correlator) "\n\n") - (while results - (insert (car results)) - (or (bolp) (insert "\\\n")) - (if helpp - nil - (if (cadr results) - (mapcar (function (lambda (value) - (insert " => " value "\n"))) - (cadr results)) - (insert " => no (or unspecified) value\n")) - (insert "\n")) - (setq results (cddr results))) - (if stack-available - (let ((beg (point)) - (map (make-sparse-keymap))) - (define-key map [mouse-1] 'gds-show-last-stack) - (define-key map "\C-m" 'gds-show-last-stack) - (insert "[click here to show error stack]") - (add-text-properties beg (point) - (list 'keymap map - 'mouse-face 'highlight)) - (insert "\n"))) - (goto-char (point-min)) - (gds-associate-buffer client)) - (pop-to-buffer buf) - (run-hooks 'temp-buffer-show-hook))))) - -(defun gds-show-last-stack () - "Show stack of the most recent error." - (interactive) - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (gds-send "debug-lazy-trap-context" gds-client)) - -;;;; Completion. - -(defvar gds-completion-results nil) - -(defun gds-complete-symbol () - "Complete the Guile symbol before point. Returns `t' if anything -interesting happened, `nil' if not." - (interactive) - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (let* ((chars (- (point) (save-excursion - (while (let ((syntax (char-syntax (char-before (point))))) - (or (eq syntax ?w) (eq syntax ?_))) - (forward-char -1)) - (point))))) - (if (zerop chars) - nil - (setq gds-completion-results nil) - (gds-send (format "complete %s" - (prin1-to-string - (buffer-substring-no-properties (- (point) chars) - (point)))) - gds-client) - (while (null gds-completion-results) - (accept-process-output gds-debug-server 0 200)) - (cond ((eq gds-completion-results 'error) - (error "Internal error - please report the contents of the *Guile Evaluation* window")) - ((eq gds-completion-results t) - nil) - ((stringp gds-completion-results) - (if (<= (length gds-completion-results) chars) - nil - (insert (substring gds-completion-results chars)) - (message "Sole completion") - t)) - ((= (length gds-completion-results) 1) - (if (<= (length (car gds-completion-results)) chars) - nil - (insert (substring (car gds-completion-results) chars)) - t)) - (t - (with-output-to-temp-buffer "*Completions*" - (display-completion-list gds-completion-results)) - t))))) - -;;;; Breakpoints. - -(defvar gds-bufferless-breakpoints nil - "The list of breakpoints that are not yet associated with a -particular buffer. Each element looks like (BPDEF BPNUM) where BPDEF -is the breakpoint definition and BPNUM the breakpoint's unique -GDS-assigned number. A breakpoint definition BPDEF is a list of the -form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug -or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file -where the breakpoint is (or will be) set, and TYPE-ARGS is: - -- the name of the procedure to break in, if TYPE is 'in - -- the line number and column number to break at, if TYPE is 'at. - -If persistent breakpoints are enabled (by configuring -gds-breakpoints-file-name), this list is initialized when GDS is -loaded by reading gds-breakpoints-file-name.") - -(defsubst gds-bpdef:behaviour (bpdef) - (nth 0 bpdef)) - -(defsubst gds-bpdef:type (bpdef) - (nth 1 bpdef)) - -(defsubst gds-bpdef:file-name (bpdef) - (nth 2 bpdef)) - -(defsubst gds-bpdef:proc-name (bpdef) - (nth 3 bpdef)) - -(defsubst gds-bpdef:lc (bpdef) - (nth 3 bpdef)) - -(defvar gds-breakpoint-number 0 - "The last assigned breakpoint number. GDS increments this whenever -it creates a new breakpoint.") - -(defvar gds-breakpoint-buffers nil - "The list of buffers that contain GDS breakpoints. When Emacs -visits a Scheme file, GDS checks to see if any of the breakpoints in -the bufferless list can be assigned to that file's buffer. If they -can, they are removed from the bufferless list and become breakpoint -overlays in that buffer. To retain the ability to enumerate all -breakpoints, therefore, we keep a list of all such buffers.") - -(defvar gds-breakpoint-programming nil - "Information about how each breakpoint is actually programmed in the -Guile clients that GDS is connected to. This is an alist of the form -\((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint -number, CLIENT is the number of a GDS client, and TRAPLIST is the list -of traps that that client has created for the breakpoint concerned (in -an arbitrary but Emacs-readable format).") - -(defvar gds-breakpoint-cache nil - "Buffer-local cache of breakpoints in a particular buffer. When a -breakpoint is represented as an overlay is a Scheme mode buffer, we -need to be able to detect when the user has caused that overlay to -evaporate by deleting a region of code that included it. We do this -detection when the buffer is next saved, by comparing the current set -of overlays with this cache. The cache is a list in which each -element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already -described. The handling of such breakpoints (which we call \"lost\") -is controlled by the setting of gds-delete-lost-breakpoints.") -(make-variable-buffer-local 'gds-breakpoint-cache) - -(defface gds-breakpoint-face - '((((background dark)) (:background "red")) - (t (:background "pink"))) - "*Face used to highlight the location of a breakpoint." - :group 'gds) - -(defcustom gds-breakpoints-file-name "~/.gds-breakpoints" - "Name of file used to store GDS breakpoints between sessions. -You can disable breakpoint persistence by setting this to nil." - :group 'gds - :type '(choice (const :tag "nil" nil) file)) - -(defcustom gds-delete-lost-breakpoints nil - "Whether to delete lost breakpoints. - -A non-nil value means that the Guile clients where lost breakpoints -were programmed will be told immediately to delete their breakpoints. -\"Immediately\" means when the lost breakpoints are detected, which -means when the buffer that previously contained them is saved. Thus, -even if the affected code (which the GDS user has deleted from his/her -buffer in Emacs) is still in use in the Guile clients, the breakpoints -that were previously set in that code will no longer take effect. - -Nil (which is the default) means that GDS leaves such breakpoints -active in their Guile clients. This allows those breakpoints to -continue taking effect until the affected code is no longer used by -the Guile clients." - :group 'gds - :type 'boolean) - -(defvar gds-bpdefs-cache nil) - -(defun gds-read-breakpoints-file () - "Read the persistent breakpoints file, and use its contents to -initialize GDS's global breakpoint variables." - (let ((bpdefs (condition-case nil - (with-current-buffer - (find-file-noselect gds-breakpoints-file-name) - (goto-char (point-min)) - (read (current-buffer))) - (error nil)))) - ;; Cache the overall value so we don't unnecessarily modify the - ;; breakpoints buffer when `gds-write-breakpoints-file' is called. - (setq gds-bpdefs-cache bpdefs) - ;; Move definitions into the bufferless breakpoint list, assigning - ;; breakpoint numbers as we go. - (setq gds-bufferless-breakpoints - (mapcar (function (lambda (bpdef) - (setq gds-breakpoint-number - (1+ gds-breakpoint-number)) - (list bpdef gds-breakpoint-number))) - bpdefs)) - ;; Check each existing Scheme buffer to see if it wants to take - ;; ownership of any of these breakpoints. - (mapcar (function (lambda (buffer) - (with-current-buffer buffer - (if (eq (derived-mode-class major-mode) 'scheme-mode) - (gds-adopt-breakpoints))))) - (buffer-list)))) - -(defun gds-adopt-breakpoints () - "Take ownership of any of the breakpoints in the bufferless list -that match the current buffer." - (mapcar (function gds-adopt-breakpoint) - (copy-sequence gds-bufferless-breakpoints))) - -(defun gds-adopt-breakpoint (bpdefnum) - "Take ownership of the specified breakpoint if it matches the -current buffer." - (let ((bpdef (car bpdefnum)) - (bpnum (cadr bpdefnum))) - ;; Check if breakpoint's file name matches. If it does, try to - ;; convert the breakpoint definition to a breakpoint overlay in - ;; the current buffer. - (if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name) - (gds-make-breakpoint-overlay bpdef bpnum)) - ;; That all succeeded, so this breakpoint is no longer - ;; bufferless. - (setq gds-bufferless-breakpoints - (delq bpdefnum gds-bufferless-breakpoints))))) - -(defun gds-make-breakpoint-overlay (bpdef &optional bpnum) - ;; If no explicit number given, assign the next available breakpoint - ;; number. - (or bpnum - (setq gds-breakpoint-number (+ gds-breakpoint-number 1) - bpnum gds-breakpoint-number)) - ;; First decide where the overlay should be, and create it there. - (let ((o (cond ((eq (gds-bpdef:type bpdef) 'at) - (save-excursion - (goto-line (+ (car (gds-bpdef:lc bpdef)) 1)) - (move-to-column (cdr (gds-bpdef:lc bpdef))) - (make-overlay (point) (1+ (point))))) - ((eq (gds-bpdef:type bpdef) 'in) - (save-excursion - (goto-char (point-min)) - (and (re-search-forward (concat "^(define +(?\\(" - (regexp-quote - (gds-bpdef:proc-name - bpdef)) - "\\>\\)") - nil t) - (make-overlay (match-beginning 1) (match-end 1))))) - (t - (error "Bad breakpoint type"))))) - ;; If that succeeded, initialize the overlay's properties. - (if o - (progn - (overlay-put o 'evaporate t) - (overlay-put o 'face 'gds-breakpoint-face) - (overlay-put o 'gds-breakpoint-number bpnum) - (overlay-put o 'gds-breakpoint-definition bpdef) - (overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef)) - (overlay-put o 'priority 1000) - ;; Make sure that the current buffer is included in - ;; `gds-breakpoint-buffers'. - (or (memq (current-buffer) gds-breakpoint-buffers) - (setq gds-breakpoint-buffers - (cons (current-buffer) gds-breakpoint-buffers))) - ;; Add the new breakpoint to this buffer's cache. - (setq gds-breakpoint-cache - (cons (list bpdef bpnum) gds-breakpoint-cache)) - ;; If this buffer is associated with a client, tell the - ;; client about the new breakpoint. - (if gds-client (gds-send-breakpoint-to-client bpnum bpdef)))) - ;; Return the overlay, or nil if we weren't able to convert the - ;; breakpoint definition. - o)) - -(defun gds-send-breakpoint-to-client (bpnum bpdef) - "Send specified breakpoint to this buffer's Guile client." - (gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client)) - -(add-hook 'scheme-mode-hook (function gds-adopt-breakpoints)) - -(defcustom gds-default-breakpoint-type 'debug - "The type of breakpoint set by `C-x SPC'." - :group 'gds - :type '(choice (const :tag "debug" debug) (const :tag "trace" trace))) - -(defun gds-set-breakpoint () - "Create a new GDS breakpoint at point." - (interactive) - ;; Set up beg and end according to whether the mark is active. - (if mark-active - ;; Set new breakpoints on all opening parentheses in the region. - (let ((beg (region-beginning)) - (end (region-end))) - (save-excursion - (goto-char beg) - (beginning-of-defun) - (let ((defun-start (point))) - (goto-char beg) - (while (search-forward "(" end t) - (let ((state (parse-partial-sexp defun-start (point))) - (pos (- (point) 1))) - (or (nth 3 state) - (nth 4 state) - (gds-breakpoint-overlays-at pos) - (gds-make-breakpoint-overlay (list gds-default-breakpoint-type - 'at - buffer-file-name - (gds-line-and-column - pos))))))))) - ;; Set a new breakpoint on the defun at point. - (let ((region (gds-defun-name-region))) - ;; Complain if there is no defun at point. - (or region - (error "Point is not in a procedure definition")) - ;; Don't create another breakpoint if there is already one here. - (if (gds-breakpoint-overlays-at (car region)) - (error "There is already a breakpoint here")) - ;; Create and return the new breakpoint overlay. - (gds-make-breakpoint-overlay (list gds-default-breakpoint-type - 'in - buffer-file-name - (buffer-substring-no-properties - (car region) - (cdr region)))))) - ;; Update the persistent breakpoints file. - (gds-write-breakpoints-file)) - -(defun gds-defun-name-region () - "If point is in a defun, return the beginning and end positions of -the identifier being defined." - (save-excursion - (let ((p (point))) - (beginning-of-defun) - ;; Check that we are looking at some kind of procedure - ;; definition. - (and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)") - (let ((beg (match-beginning 1)) - (end (match-end 1))) - (end-of-defun) - ;; Check here that we have reached past the original point - ;; position. - (and (>= (point) p) - (cons beg end))))))) - -(defun gds-breakpoint-overlays-at (pos) - "Return a list of GDS breakpoint overlays at the specified position." - (let ((os (overlays-at pos)) - (breakpoint-os nil)) - ;; Of the overlays at POS, select all those that have a - ;; gds-breakpoint-definition property. - (while os - (if (overlay-get (car os) 'gds-breakpoint-definition) - (setq breakpoint-os (cons (car os) breakpoint-os))) - (setq os (cdr os))) - breakpoint-os)) - -(defun gds-write-breakpoints-file () - "Write the persistent breakpoints file, if configured." - (if gds-breakpoints-file-name - (let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init) - (cons bpdef init))) - t))) - (or (equal bpdefs gds-bpdefs-cache) - (with-current-buffer (find-file-noselect gds-breakpoints-file-name) - (erase-buffer) - (pp (reverse bpdefs) (current-buffer)) - (setq gds-bpdefs-cache bpdefs) - (let ((auto-fill-function normal-auto-fill-function)) - (newline))))))) - -(defun gds-fold-breakpoints (fn &optional foldp init) - ;; Run through bufferless breakpoints first. - (let ((bbs gds-bufferless-breakpoints)) - (while bbs - (let ((bpnum (cadr (car bbs))) - (bpdef (caar bbs))) - (if foldp - (setq init (funcall fn bpnum bpdef init)) - (funcall fn bpnum bpdef))) - (setq bbs (cdr bbs)))) - ;; Now run through breakpoint buffers. - (let ((outbuf (current-buffer)) - (bpbufs gds-breakpoint-buffers)) - (while bpbufs - (let ((buf (car bpbufs))) - (if (buffer-live-p buf) - (with-current-buffer buf - (save-restriction - (widen) - (let ((os (overlays-in (point-min) (point-max)))) - (while os - (let ((bpnum (overlay-get (car os) - 'gds-breakpoint-number)) - (bpdef (overlay-get (car os) - 'gds-breakpoint-definition))) - (if bpdef - (with-current-buffer outbuf - (if foldp - (setq init (funcall fn bpnum bpdef init)) - (funcall fn bpnum bpdef))))) - (setq os (cdr os)))))))) - (setq bpbufs (cdr bpbufs)))) - init) - -(defun gds-delete-breakpoints () - "Delete GDS breakpoints in the region or at point." - (interactive) - (if mark-active - ;; Delete all breakpoints in the region. - (let ((os (overlays-in (region-beginning) (region-end)))) - (while os - (if (overlay-get (car os) 'gds-breakpoint-definition) - (gds-delete-breakpoint (car os))) - (setq os (cdr os)))) - ;; Delete the breakpoint "at point". - (call-interactively (function gds-delete-breakpoint)))) - -(defun gds-delete-breakpoint (o) - (interactive (list (or (gds-breakpoint-at-point) - (error "There is no breakpoint here")))) - (let ((bpdef (overlay-get o 'gds-breakpoint-definition)) - (bpnum (overlay-get o 'gds-breakpoint-number))) - ;; If this buffer is associated with a client, tell the client - ;; that the breakpoint has been deleted. - (if (and bpnum gds-client) - (gds-send (format "delete-breakpoint %d" bpnum) gds-client)) - ;; Remove this breakpoint from the cache also, so it isn't later - ;; detected as having been "lost". - (setq gds-breakpoint-cache - (delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache))) - ;; Remove the overlay from its buffer. - (delete-overlay o) - ;; If that was the last breakpoint in this buffer, remove this - ;; buffer from gds-breakpoint-buffers. - (or gds-breakpoint-cache - (setq gds-breakpoint-buffers - (delq (current-buffer) gds-breakpoint-buffers))) - ;; Update the persistent breakpoints file. - (gds-write-breakpoints-file)) - -(defun gds-breakpoint-at-point () - "Find and return the overlay for a breakpoint `at' the current -cursor position. This is intended for use in other functions' -interactive forms, so it intentionally uses the minibuffer in some -situations." - (let* ((region (gds-defun-name-region)) - (os (gds-union (gds-breakpoint-overlays-at (point)) - (and region - (gds-breakpoint-overlays-at (car region)))))) - ;; Switch depending whether we found 0, 1 or more overlays. - (cond ((null os) - ;; None found: return nil. - nil) - ((= (length os) 1) - ;; One found: return it. - (car os)) - (t - ;; More than 1 found: ask the user to choose. - (gds-user-selected-breakpoint os))))) - -(defun gds-union (first second &rest others) - (if others - (gds-union first (apply 'gds-union second others)) - (progn - (while first - (or (memq (car first) second) - (setq second (cons (car first) second))) - (setq first (cdr first))) - second))) - -(defun gds-user-selected-breakpoint (os) - "Ask the user to choose one of the given list of breakpoints, and -return the one that they chose." - (let ((table (mapcar - (lambda (o) - (cons (format "%S" - (overlay-get o 'gds-breakpoint-definition)) - o)) - os))) - (cdr (assoc (completing-read "Which breakpoint do you mean? " - table nil t) - table)))) - -(defun gds-describe-breakpoints () - "Describe all breakpoints and their programming status." - (interactive) - (with-current-buffer (get-buffer-create "*GDS Breakpoints*") - (erase-buffer) - (gds-fold-breakpoints (function gds-describe-breakpoint)) - (display-buffer (current-buffer)))) - -(defun gds-describe-breakpoint (bpnum bpdef) - (insert (format "Breakpoint %d: %S\n" bpnum bpdef)) - (let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming)))) - (mapcar (lambda (clientprog) - (let ((client (car clientprog)) - (traplist (cdr clientprog))) - (mapcar (lambda (trap) - (insert (format " Client %d: %S\n" client trap))) - traplist))) - bpproglist))) - -(defun gds-after-save-update-breakpoints () - "Function called when a buffer containing breakpoints is saved." - (if (eq (derived-mode-class major-mode) 'scheme-mode) - (save-restriction - (widen) - ;; Get the current breakpoint overlays. - (let ((os (overlays-in (point-min) (point-max))) - (cache (copy-sequence gds-breakpoint-cache))) - ;; Identify any overlays that have disappeared by comparing - ;; against this buffer's definition cache, and - ;; simultaneously rebuild the cache to reflect the current - ;; set of overlays. - (setq gds-breakpoint-cache nil) - (while os - (let* ((o (car os)) - (bpdef (overlay-get o 'gds-breakpoint-definition)) - (bpnum (overlay-get o 'gds-breakpoint-number))) - (if bpdef - ;; o and bpdef describe a current breakpoint. - (progn - ;; Remove this breakpoint from the old cache list, - ;; so we don't think it got lost. - (setq cache (delq (assq bpdef cache) cache)) - ;; Check whether this breakpoint's location has - ;; moved. If it has, update the breakpoint - ;; definition and the associated client. - (let ((lcnow (gds-line-and-column (overlay-start o)))) - (if (equal lcnow (gds-bpdef:lc bpdef)) - nil ; Breakpoint hasn't moved. - (gds-bpdef:setlc bpdef lcnow) - (if gds-client - (gds-send-breakpoint-to-client bpnum bpdef)))) - ;; Add this breakpoint to the new cache list. - (setq gds-breakpoint-cache - (cons (list bpdef bpnum) gds-breakpoint-cache))))) - (setq os (cdr os))) - ;; cache now holds the set of lost breakpoints. If we are - ;; supposed to explicitly delete these from the associated - ;; client, do that now. - (if (and gds-delete-lost-breakpoints gds-client) - (while cache - (gds-send (format "delete-breakpoint %d" (cadr (car cache))) - gds-client) - (setq cache (cdr cache))))) - ;; If this buffer now has no breakpoints, remove it from - ;; gds-breakpoint-buffers. - (or gds-breakpoint-cache - (setq gds-breakpoint-buffers - (delq (current-buffer) gds-breakpoint-buffers))) - ;; Update the persistent breakpoints file. - (gds-write-breakpoints-file)))) - -(add-hook 'after-save-hook (function gds-after-save-update-breakpoints)) - -;;;; Dispatcher for non-debug protocol. - -(defun gds-nondebug-protocol (client proc args) - (cond (;; (eval-results ...) - Results of evaluation. - (eq proc 'eval-results) - (gds-display-results client (car args) (cadr args) (cddr args)) - ;; If these results indicate an error, set - ;; gds-completion-results to non-nil in case the error arose - ;; when trying to do a completion. - (if (eq (caar args) 'error) - (setq gds-completion-results 'error))) - - (;; (completion-result ...) - Available completions. - (eq proc 'completion-result) - (setq gds-completion-results (or (car args) t))) - - (;; (breakpoint NUM STATUS) - Breakpoint set. - (eq proc 'breakpoint) - (let* ((bpnum (car args)) - (traplist (cdr args)) - (bpentry (assq bpnum gds-breakpoint-programming))) - (message "Breakpoint %d: %s" bpnum traplist) - (if bpentry - (let ((cliententry (assq client (cdr bpentry)))) - (if cliententry - (setcdr cliententry traplist) - (setcdr bpentry - (cons (cons client traplist) (cdr bpentry))))) - (setq gds-breakpoint-programming - (cons (list bpnum (cons client traplist)) - gds-breakpoint-programming))))) - - (;; (get-breakpoints) - Set all breakpoints. - (eq proc 'get-breakpoints) - (let ((gds-client client)) - (gds-fold-breakpoints (function gds-send-breakpoint-to-client))) - (gds-send "continue" client)) - - (;; (note ...) - For debugging only. - (eq proc 'note)) - - (;; (trace ...) - Tracing. - (eq proc 'trace) - (with-current-buffer (get-buffer-create "*GDS Trace*") - (save-excursion - (goto-char (point-max)) - (or (bolp) (insert "\n")) - (insert "[client " (number-to-string client) "] " (car args) "\n")))) - - (t - ;; Unexpected. - (error "Bad protocol: %S" form)))) - -;;;; Scheme mode keymap items. - -(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun) -(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp) -(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) -(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) -(define-key scheme-mode-map "\C-hg" 'gds-help-symbol) -(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) -(define-key scheme-mode-map "\C-hG" 'gds-apropos) -(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack) -(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) -(define-key scheme-mode-map "\C-x " 'gds-set-breakpoint) - -(define-prefix-command 'gds-breakpoint-map) -(define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map) -(define-key gds-breakpoint-map " " 'gds-set-breakpoint) -(define-key gds-breakpoint-map "d" - (function (lambda () - (interactive) - (let ((gds-default-breakpoint-type 'debug)) - (gds-set-breakpoint))))) -(define-key gds-breakpoint-map "t" - (function (lambda () - (interactive) - (let ((gds-default-breakpoint-type 'trace)) - (gds-set-breakpoint))))) -(define-key gds-breakpoint-map "T" - (function (lambda () - (interactive) - (let ((gds-default-breakpoint-type 'trace-subtree)) - (gds-set-breakpoint))))) -(define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints) -(define-key gds-breakpoint-map "?" 'gds-describe-breakpoints) - -;;;; The end! - -(provide 'gds-scheme) - -;;; gds-scheme.el ends here. rmfile ./site-lisp/gds-scheme.el hunk ./site-lisp/gds-server.el 1 -;;; gds-server.el -- infrastructure for running GDS server processes - -;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later -;;;; version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free -;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;;; 02111-1307 USA - - -;;;; Customization group setup. - -(defgroup gds nil - "Customization options for Guile Emacs frontend." - :group 'scheme) - - -;;;; Communication with the (ice-9 gds-server) subprocess. - -;; Subprocess output goes into the `*GDS Process*' buffer, and -;; is then read from there one form at a time. `gds-read-cursor' is -;; the buffer position of the start of the next unread form. -(defvar gds-read-cursor nil) - -;; The guile executable used by the GDS server process. -(defcustom gds-guile-program "guile" - "*The guile executable used by the GDS server process." - :type 'string - :group 'gds) - -(defcustom gds-scheme-directory nil - "Where GDS's Scheme code is, if not in one of the standard places." - :group 'gds - :type '(choice (const :tag "nil" nil) directory)) - -(defun gds-start-server (procname port-or-path protocol-handler &optional bufname) - "Start a GDS server process called PROCNAME, listening on TCP port -or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a -function that accepts and processes one protocol form. Optional arg -BUFNAME specifies the name of the buffer that is used for process -output; if not specified the buffer name is the same as the process -name." - (with-current-buffer (get-buffer-create (or bufname procname)) - (erase-buffer) - (let* ((code (format "(begin - %s - (use-modules (ice-9 gds-server)) - (run-server %S))" - (if gds-scheme-directory - (concat "(set! %load-path (cons " - (format "%S" gds-scheme-directory) - " %load-path))") - "") - port-or-path)) - (process-connection-type nil) ; use a pipe - (proc (start-process procname - (current-buffer) - gds-guile-program - "-q" - "--debug" - "-c" - code))) - (set (make-local-variable 'gds-read-cursor) (point-min)) - (set (make-local-variable 'gds-protocol-handler) protocol-handler) - (set-process-filter proc (function gds-filter)) - (set-process-sentinel proc (function gds-sentinel)) - (set-process-coding-system proc 'latin-1-unix) - (process-kill-without-query proc) - proc))) - -;; Subprocess output filter: inserts normally into the process buffer, -;; then tries to reread the output one form at a time and delegates -;; processing of each form to `gds-protocol-handler'. -(defun gds-filter (proc string) - (with-current-buffer (process-buffer proc) - (save-excursion - (goto-char (process-mark proc)) - (insert-before-markers string)) - (goto-char gds-read-cursor) - (while (let ((form (condition-case nil - (read (current-buffer)) - (error nil)))) - (if form - (save-excursion - (funcall gds-protocol-handler (car form) (cdr form)))) - form) - (setq gds-read-cursor (point))))) - -;; Subprocess sentinel: do nothing. (Currently just here to avoid -;; inserting un-`read'able process status messages into the process -;; buffer.) -(defun gds-sentinel (proc event) - ) - - -;;;; The end! - -(provide 'gds-server) - -;;; gds-server.el ends here. rmfile ./site-lisp/gds-server.el hunk ./site-lisp/gds.el 1 -;;; gds.el -- frontend for Guile development in Emacs - -;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later -;;;; version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free -;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;;; 02111-1307 USA - -; TODO: -; ?transcript -; scheme-mode menu -; interrupt/sigint/async-break -; (module browsing) -; load file -; doing common protocol from debugger -; thread override for debugging - -;;;; Prerequisites. - -(require 'scheme) -(require 'cl) -(require 'gds-server) -(require 'gds-scheme) - -;; The subprocess object for the debug server. -(defvar gds-debug-server nil) - -(defvar gds-socket-type-alist '((tcp . 8333) - (unix . "/tmp/.gds_socket")) - "Maps each of the possible socket types that the GDS server can -listen on to the path that it should bind to for each one.") - -(defun gds-run-debug-server () - "Start (or restart, if already running) the GDS debug server process." - (interactive) - (if gds-debug-server (gds-kill-debug-server)) - (setq gds-debug-server - (gds-start-server "gds-debug" - (cdr (assq gds-server-socket-type - gds-socket-type-alist)) - 'gds-debug-protocol)) - (process-kill-without-query gds-debug-server)) - -(defun gds-kill-debug-server () - "Kill the GDS debug server process." - (interactive) - (mapcar (function gds-client-gone) - (mapcar (function car) gds-client-info)) - (condition-case nil - (progn - (kill-process gds-debug-server) - (accept-process-output gds-debug-server 0 200)) - (error)) - (setq gds-debug-server nil)) - -;; Send input to the subprocess. -(defun gds-send (string client) - (with-current-buffer (get-buffer-create "*GDS Transcript*") - (goto-char (point-max)) - (insert (number-to-string client) ": (" string ")\n")) - (gds-client-put client 'thread-id nil) - (gds-show-client-status client gds-running-text) - (process-send-string gds-debug-server (format "(%S %s)\n" client string))) - - -;;;; Per-client information - -(defun gds-client-put (client property value) - (let ((client-info (assq client gds-client-info))) - (if client-info - (let ((prop-info (memq property client-info))) - (if prop-info - (setcar (cdr prop-info) value) - (setcdr client-info - (list* property value (cdr client-info))))) - (setq gds-client-info - (cons (list client property value) gds-client-info))))) - -(defun gds-client-get (client property) - (let ((client-info (assq client gds-client-info))) - (and client-info - (cadr (memq property client-info))))) - -(defvar gds-client-info '()) - -(defun gds-get-client-buffer (client) - (let ((existing-buffer (gds-client-get client 'stack-buffer))) - (if (and existing-buffer - (buffer-live-p existing-buffer)) - existing-buffer - (let ((new-buffer (generate-new-buffer (gds-client-get client 'name)))) - (with-current-buffer new-buffer - (gds-debug-mode) - (setq gds-client client) - (setq gds-stack nil)) - (gds-client-put client 'stack-buffer new-buffer) - new-buffer)))) - -(defun gds-client-gone (client &rest ignored) - ;; Kill the client's stack buffer, if it has one. - (let ((stack-buffer (gds-client-get client 'stack-buffer))) - (if (and stack-buffer - (buffer-live-p stack-buffer)) - (kill-buffer stack-buffer))) - ;; Dissociate all the client's associated buffers. - (mapcar (function (lambda (buffer) - (if (buffer-live-p buffer) - (with-current-buffer buffer - (gds-dissociate-buffer))))) - (copy-sequence (gds-client-get client 'associated-buffers))) - ;; Remove this client's record from gds-client-info. - (setq gds-client-info (delq (assq client gds-client-info) gds-client-info))) - -(defvar gds-client nil) -(make-variable-buffer-local 'gds-client) - -(defvar gds-stack nil) -(make-variable-buffer-local 'gds-stack) - -(defvar gds-tweaking nil) -(make-variable-buffer-local 'gds-tweaking) - -(defvar gds-selected-frame-index nil) -(make-variable-buffer-local 'gds-selected-frame-index) - - -;;;; Debugger protocol - -(defun gds-debug-protocol (client form) - (or (eq client '*) - (let ((proc (car form))) - (cond ((eq proc 'name) - ;; (name ...) - client name. - (gds-client-put client 'name (caddr form))) - - ((eq proc 'stack) - ;; (stack ...) - stack information. - (with-current-buffer (gds-get-client-buffer client) - (setq gds-stack (cddr form)) - (setq gds-tweaking (memq 'instead (cadr gds-stack))) - (setq gds-selected-frame-index (cadr form)) - (gds-display-stack))) - - ((eq proc 'closed) - ;; (closed) - client has gone/died. - (gds-client-gone client)) - - ((eq proc 'eval-result) - ;; (eval-result RESULT) - result of evaluation. - (if gds-last-eval-result - (message "%s" (cadr form)) - (setq gds-last-eval-result (cadr form)))) - - ((eq proc 'info-result) - ;; (info-result RESULT) - info about selected frame. - (message "%s" (cadr form))) - - ((eq proc 'thread-id) - ;; (thread-id THREAD) - says which client thread is reading. - (let ((thread-id (cadr form)) - (debug-thread-id (gds-client-get client 'debug-thread-id))) - (if (and debug-thread-id - (/= thread-id debug-thread-id)) - ;; Tell the newly reading thread to go away. - (gds-send "dismiss" client) - ;; Either there's no current debug-thread-id, or - ;; the thread now reading is the debug thread. - (if debug-thread-id - (progn - ;; Reset the debug-thread-id. - (gds-client-put client 'debug-thread-id nil) - ;; Indicate debug status in modelines. - (gds-show-client-status client gds-debug-text)) - ;; Indicate normal read status in modelines.. - (gds-show-client-status client gds-ready-text))))) - - ((eq proc 'debug-thread-id) - ;; (debug-thread-id THREAD) - debug override indication. - (gds-client-put client 'debug-thread-id (cadr form)) - ;; If another thread is already reading, send it away. - (if (gds-client-get client 'thread-id) - (gds-send "dismiss" client))) - - (t - ;; Non-debug-specific protocol. - (gds-nondebug-protocol client proc (cdr form))))))) - - -;;;; Displaying a stack - -(define-derived-mode gds-debug-mode - scheme-mode - "Guile-Debug" - "Major mode for debugging a Guile client application." - (use-local-map gds-mode-map)) - -(defun gds-display-stack-first-line () - (let ((flags (cadr gds-stack))) - (cond ((memq 'application flags) - (insert "Calling procedure:\n")) - ((memq 'evaluation flags) - (insert "Evaluating expression" - (cond ((stringp gds-tweaking) (format " (tweaked: %s)" - gds-tweaking)) - (gds-tweaking " (tweakable)") - (t "")) - ":\n")) - ((memq 'return flags) - (let ((value (cadr (memq 'return flags)))) - (while (string-match "\n" value) - (setq value (replace-match "\\n" nil t value))) - (insert "Return value" - (cond ((stringp gds-tweaking) (format " (tweaked: %s)" - gds-tweaking)) - (gds-tweaking " (tweakable)") - (t "")) - ": " value "\n"))) - ((memq 'error flags) - (let ((value (cadr (memq 'error flags)))) - (while (string-match "\n" value) - (setq value (replace-match "\\n" nil t value))) - (insert "Error: " value "\n"))) - (t - (insert "Stack: " (prin1-to-string flags) "\n"))))) - -(defun gds-display-stack () - (if gds-undisplay-timer - (cancel-timer gds-undisplay-timer)) - (setq gds-undisplay-timer nil) - ;(setq buffer-read-only nil) - (mapcar 'delete-overlay - (overlays-in (point-min) (point-max))) - (erase-buffer) - (gds-display-stack-first-line) - (let ((frames (car gds-stack))) - (while frames - (let ((frame-text (cadr (car frames))) - (frame-source (caddr (car frames)))) - (while (string-match "\n" frame-text) - (setq frame-text (replace-match "\\n" nil t frame-text))) - (insert " " - (if frame-source "s" " ") - frame-text - "\n")) - (setq frames (cdr frames)))) - ;(setq buffer-read-only t) - (gds-show-selected-frame)) - -(defun gds-tweak (expr) - (interactive "sTweak expression or return value: ") - (or gds-tweaking - (error "The current stack cannot be tweaked")) - (setq gds-tweaking - (if (> (length expr) 0) - expr - t)) - (save-excursion - (goto-char (point-min)) - (delete-region (point) (progn (forward-line 1) (point))) - (gds-display-stack-first-line))) - -(defvar gds-undisplay-timer nil) -(make-variable-buffer-local 'gds-undisplay-timer) - -(defvar gds-undisplay-wait 1) - -(defun gds-undisplay-buffer () - (if gds-undisplay-timer - (cancel-timer gds-undisplay-timer)) - (setq gds-undisplay-timer - (run-at-time gds-undisplay-wait - nil - (function kill-buffer) - (current-buffer)))) - -(defun gds-show-selected-frame () - (setq gds-local-var-cache nil) - (goto-char (point-min)) - (forward-line (+ gds-selected-frame-index 1)) - (delete-char 3) - (insert "=> ") - (beginning-of-line) - (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index - (car gds-stack))))) - -(defun gds-unshow-selected-frame () - (if gds-frame-source-overlay - (move-overlay gds-frame-source-overlay 0 0)) - (save-excursion - (goto-char (point-min)) - (forward-line (+ gds-selected-frame-index 1)) - (delete-char 3) - (insert " "))) - -;; Overlay used to highlight the source expression corresponding to -;; the selected frame. -(defvar gds-frame-source-overlay nil) - -(defcustom gds-source-file-name-transforms nil - "Alist of regexps and substitutions for transforming Scheme source -file names. Each element in the alist is (REGEXP . SUBSTITUTION). -Each source file name in a Guile backtrace is compared against each -REGEXP in turn until the first one that matches, then `replace-match' -is called with SUBSTITUTION to transform that file name. - -This mechanism targets the situation where you are working on a Guile -application and want to install it, in /usr/local say, before each -test run. In this situation, even though Guile is reading your Scheme -files from /usr/local/share/guile, you probably want Emacs to pop up -the corresponding files from your working codebase instead. Therefore -you would add an element to this alist to transform -\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"." - :type '(alist :key-type regexp :value-type string) - :group 'gds) - -(defun gds-show-selected-frame-source (source) - ;; Highlight the frame source, if possible. - (if source - (let ((filename (car source)) - (client gds-client) - (transforms gds-source-file-name-transforms)) - ;; Apply possible transforms to the source file name. - (while transforms - (if (string-match (caar transforms) filename) - (let ((trans-fn (replace-match (cdar transforms) - t nil filename))) - (if (file-readable-p trans-fn) - (setq filename trans-fn - transforms nil)))) - (setq transforms (cdr transforms))) - ;; Try to map the (possibly transformed) source file to a - ;; buffer. - (let ((source-buffer (gds-source-file-name-to-buffer filename))) - (if source-buffer - (with-current-buffer source-buffer - (if gds-frame-source-overlay - nil - (setq gds-frame-source-overlay (make-overlay 0 0)) - (overlay-put gds-frame-source-overlay 'face 'highlight) - (overlay-put gds-frame-source-overlay - 'help-echo - (function gds-show-local-var))) - ;; Move to source line. Note that Guile line numbering - ;; is 0-based, while Emacs numbering is 1-based. - (save-restriction - (widen) - (goto-line (+ (cadr source) 1)) - (move-to-column (caddr source)) - (move-overlay gds-frame-source-overlay - (point) - (if (not (looking-at ")")) - (save-excursion (forward-sexp 1) (point)) - ;; It seems that the source - ;; coordinates for backquoted - ;; expressions are at the end of the - ;; sexp rather than the beginning... - (save-excursion (forward-char 1) - (backward-sexp 1) (point))) - (current-buffer))) - ;; Record that this source buffer has been touched by a - ;; GDS client process. - (setq gds-last-touched-by client)) - (message "Source for this frame cannot be shown: %s:%d:%d" - filename - (cadr source) - (caddr source))))) - (message "Source for this frame was not recorded")) - (gds-display-buffers)) - -(defvar gds-local-var-cache nil) - -(defun gds-show-local-var (window overlay position) - (let ((frame-index gds-selected-frame-index) - (client gds-client)) - (with-current-buffer (overlay-buffer overlay) - (save-excursion - (goto-char position) - (let ((gds-selected-frame-index frame-index) - (gds-client client) - (varname (thing-at-point 'symbol)) - (state (parse-partial-sexp (overlay-start overlay) (point)))) - (when (and gds-selected-frame-index - gds-client - varname - (not (or (nth 3 state) - (nth 4 state)))) - (set-text-properties 0 (length varname) nil varname) - (let ((existing (assoc varname gds-local-var-cache))) - (if existing - (cdr existing) - (gds-evaluate varname) - (setq gds-last-eval-result nil) - (while (not gds-last-eval-result) - (accept-process-output gds-debug-server)) - (setq gds-local-var-cache - (cons (cons varname gds-last-eval-result) - gds-local-var-cache)) - gds-last-eval-result)))))))) - -(defun gds-source-file-name-to-buffer (filename) - ;; See if filename begins with gds-emacs-buffer-port-name-prefix. - (if (string-match (concat "^" - (regexp-quote gds-emacs-buffer-port-name-prefix)) - filename) - ;; It does, so get the named buffer. - (get-buffer (substring filename (match-end 0))) - ;; It doesn't, so treat as a file name. - (and (file-readable-p filename) - (find-file-noselect filename)))) - -(defun gds-select-stack-frame (&optional frame-index) - (interactive) - (let ((new-frame-index (or frame-index - (gds-current-line-frame-index)))) - (or (and (>= new-frame-index 0) - (< new-frame-index (length (car gds-stack)))) - (error (if frame-index - "No more frames in this direction" - "No frame here"))) - (gds-unshow-selected-frame) - (setq gds-selected-frame-index new-frame-index) - (gds-show-selected-frame))) - -(defun gds-up () - (interactive) - (gds-select-stack-frame (- gds-selected-frame-index 1))) - -(defun gds-down () - (interactive) - (gds-select-stack-frame (+ gds-selected-frame-index 1))) - -(defun gds-current-line-frame-index () - (- (count-lines (point-min) - (save-excursion - (beginning-of-line) - (point))) - 1)) - -(defun gds-display-buffers () - (let ((buf (current-buffer))) - ;; If there's already a window showing the buffer, use it. - (let ((window (get-buffer-window buf t))) - (if window - (progn - (make-frame-visible (window-frame window)) - (select-window window)) - (switch-to-buffer buf) - (setq window (get-buffer-window buf t)))) - ;; If there is an associated source buffer, display it as well. - (if (and gds-frame-source-overlay - (overlay-end gds-frame-source-overlay) - (> (overlay-end gds-frame-source-overlay) 1)) - (progn - (delete-other-windows) - (let ((window (display-buffer - (overlay-buffer gds-frame-source-overlay)))) - (set-window-point window - (overlay-start gds-frame-source-overlay))))))) - - -;;;; Debugger commands. - -;; Typically but not necessarily used from the `stack' view. - -(defun gds-send-tweaking () - (if (stringp gds-tweaking) - (gds-send (format "tweak %S" gds-tweaking) gds-client))) - -(defun gds-go () - (interactive) - (gds-send-tweaking) - (gds-send "continue" gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - -(defvar gds-last-eval-result t) - -(defun gds-evaluate (expr) - (interactive "sEvaluate variable or expression: ") - (gds-send (format "evaluate %d %s" - gds-selected-frame-index - (prin1-to-string expr)) - gds-client)) - -(defun gds-frame-info () - (interactive) - (gds-send (format "info-frame %d" gds-selected-frame-index) - gds-client)) - -(defun gds-frame-args () - (interactive) - (gds-send (format "info-args %d" gds-selected-frame-index) - gds-client)) - -(defun gds-proc-source () - (interactive) - (gds-send (format "proc-source %d" gds-selected-frame-index) - gds-client)) - -(defun gds-traps-here () - (interactive) - (gds-send "traps-here" gds-client)) - -(defun gds-step-into () - (interactive) - (gds-send-tweaking) - (gds-send (format "step-into %d" gds-selected-frame-index) - gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - -(defun gds-step-over () - (interactive) - (gds-send-tweaking) - (gds-send (format "step-over %d" gds-selected-frame-index) - gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - -(defun gds-step-file () - (interactive) - (gds-send-tweaking) - (gds-send (format "step-file %d" gds-selected-frame-index) - gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - - - - -;;;; Guile Interaction mode keymap and menu items. - -(defvar gds-mode-map (make-sparse-keymap)) -(define-key gds-mode-map "c" (function gds-go)) -(define-key gds-mode-map "g" (function gds-go)) -(define-key gds-mode-map "q" (function gds-go)) -(define-key gds-mode-map "e" (function gds-evaluate)) -(define-key gds-mode-map "I" (function gds-frame-info)) -(define-key gds-mode-map "A" (function gds-frame-args)) -(define-key gds-mode-map "S" (function gds-proc-source)) -(define-key gds-mode-map "T" (function gds-traps-here)) -(define-key gds-mode-map "\C-m" (function gds-select-stack-frame)) -(define-key gds-mode-map "u" (function gds-up)) -(define-key gds-mode-map [up] (function gds-up)) -(define-key gds-mode-map "\C-p" (function gds-up)) -(define-key gds-mode-map "d" (function gds-down)) -(define-key gds-mode-map [down] (function gds-down)) -(define-key gds-mode-map "\C-n" (function gds-down)) -(define-key gds-mode-map " " (function gds-step-file)) -(define-key gds-mode-map "i" (function gds-step-into)) -(define-key gds-mode-map "o" (function gds-step-over)) -(define-key gds-mode-map "t" (function gds-tweak)) - - -(defvar gds-menu nil - "Global menu for GDS commands.") -(if nil;gds-menu - nil - (setq gds-menu (make-sparse-keymap "Guile-Debug")) - (define-key gds-menu [traps-here] - '(menu-item "Show Traps Here" gds-traps-here)) - (define-key gds-menu [proc-source] - '(menu-item "Show Procedure Source" gds-proc-source)) - (define-key gds-menu [frame-args] - '(menu-item "Show Frame Args" gds-frame-args)) - (define-key gds-menu [frame-info] - '(menu-item "Show Frame Info" gds-frame-info)) - (define-key gds-menu [separator-1] - '("--")) - (define-key gds-menu [evaluate] - '(menu-item "Evaluate..." gds-evaluate)) - (define-key gds-menu [separator-2] - '("--")) - (define-key gds-menu [down] - '(menu-item "Move Down A Frame" gds-down)) - (define-key gds-menu [up] - '(menu-item "Move Up A Frame" gds-up)) - (define-key gds-menu [separator-3] - '("--")) - (define-key gds-menu [step-over] - '(menu-item "Step Over Current Expression" gds-step-over)) - (define-key gds-menu [step-into] - '(menu-item "Step Into Current Expression" gds-step-into)) - (define-key gds-menu [step-file] - '(menu-item "Step Through Current Source File" gds-step-file)) - (define-key gds-menu [separator-4] - '("--")) - (define-key gds-menu [go] - '(menu-item "Go [continue execution]" gds-go)) - (define-key gds-mode-map [menu-bar gds-debug] - (cons "Guile-Debug" gds-menu))) - - -;;;; Autostarting the GDS server. - -(defcustom gds-autorun-debug-server t - "Whether to automatically run the GDS server when `gds.el' is loaded." - :type 'boolean - :group 'gds) - -(defcustom gds-server-socket-type 'tcp - "What kind of socket the GDS server should listen on." - :group 'gds - :type '(choice (const :tag "TCP" tcp) - (const :tag "Unix" unix))) - -;;;; If requested, autostart the server after loading. - -(if (and gds-autorun-debug-server - (not gds-debug-server)) - (gds-run-debug-server)) - -;; Things to do only when this file is loaded for the first time. -;; (And not, for example, when code is reevaluated by eval-buffer.) -(defvar gds-scheme-first-load t) -(if gds-scheme-first-load - (progn - ;; Read the persistent breakpoints file, if configured. - (if gds-breakpoints-file-name - (gds-read-breakpoints-file)) - ;; Note that first time load is complete. - (setq gds-scheme-first-load nil))) - - -;;;; The end! - -(provide 'gds) - -;;; gds.el ends here. rmfile ./site-lisp/gds.el hunk ./site-lisp/guileint-1.5/COPYING 1 - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. rmfile ./site-lisp/guileint-1.5/COPYING hunk ./site-lisp/guileint-1.5/ChangeLog 1 -1999-08-23 Mikael Djurfeldt - - * guile.el (guile-frame-eval): Made interactive. - (guile-error-map): Added guile-frame-eval under "e". - -1999-03-17 Mikael Djurfeldt - - * guile.el (guile-file-readable-p, guile-find-file-noselect): New - functions. Sets buffer to scheme-buffer before doing there - action. - (guile-display-scheme-sexp): Use the above functions. - -1999-03-16 Mikael Djurfeldt - - * guile.el (guile-buffer-file-name): Version of buffer-file-name - which uses file-truename; - Use guile-buffer-file-name throughout. - -1999-03-15 Mikael Djurfeldt - - * guileint.el: Add conditional in order not to load the interface - multiple times. - - * guile.el (scheme-virtual-file-list-find): New function. Finds - an finfo entry using a file name. Uses `file-truename'; - Replaced all assoc calls with scheme-vertual-file-list-find - everywhere. - (guile-real-safe-backward-sexp): New function. Can skip backwards - over special scheme hash-syntax. - (guile-send-input): Use `guile-real-safe-backward-sexp'. - -1999-03-01 Mikael Djurfeldt - - * inda-scheme.el (scheme-electric-open-paren), - guile.el (guile-indent-or-complete): Use indent-for-tab-command - instead of scheme-indent-line. - - * scheme.el: Merge changes from Emacs-20.3. - -1998-06-18 Mikael Djurfeldt - - * guile.el (guile-send-region): Bugfix: Calculate new value for - start if overlays have been skipped. - (guile-send-overlay): Send define-module overlay to define the - module before sending any other overlay belonging to that module. - (guile-reparse-buffer): Detect define-module expressions. - -1998-06-14 Mikael Djurfeldt - - * guile.el (guile-select-stackframe): Increment line number. - -1998-06-10 Mikael Djurfeldt - - * guile.el: Removed calls to the former debugging function `cb'. - -1998-05-21 Mikael Djurfeldt - - * guile.el: Added nil nil t arguments in calls to make-overlay in - order to make the overlays rear-sticky. (This is an adaption to - Emacs-20.) - -1997-10-22 Mikael Djurfeldt - - * guile.el (guile-stack-frame-map): Need to be fset in Emacs-20. - -Wed Oct 1 22:02:19 1997 Mikael Djurfeldt - - * inda-scheme.el (inda-inferior-initializations): Disable - font-lock-mode in inferior-scheme buffers. (For some strange - reason, the inda-read-only-overlay modification hook gets called - when a character is inserted after the prompt if font-lock mode - has been activated.) - -Fri Aug 29 01:34:34 1997 Mikael Djurfeldt - - * guile.el (guile-display-name): Bugfix: filler --> - guile-define-filler. - (guile-send-overlay): Bugfix: Don't print "DEFINED" if start /= - overlay-start. - Added (require 'cl). - (guile-insert-before-prompt): Use guile-last-output-end - -Wed Aug 27 17:24:28 1997 Mikael Djurfeldt - - * guile.el (guile-complete-symbol): Bugfix: Don't do anything if - word is nil. - (guile-backtrace-in-source-window): New customization option. - (guile-display-error): Don't place backtrace in source window if - guile-backtrace-in-source-window is nil. - (guile-prep-backtrace): Set syntax-table to - scheme-mode-syntax-table. - -Tue Aug 26 00:01:01 1997 Mikael Djurfeldt - - * guile.el (guile-insert-before-prompt): Move the recenter code - here. - (guile-display-name): Use guile-insert-before-prompt. - -Mon Aug 25 22:46:23 1997 Mikael Djurfeldt - - * guile.el (guile-display-name): Recenter display if prompt - started at the beginning of the buffer, so that the first text - inserted before prompt will be visible. - -Mon Aug 25 19:36:50 1997 Mikael Djurfeldt - - * guile.el: New variable: guile-frame-overlay. - (guile-inferior-initialize): Initialize guile-frame-overlay to - nil. - (guile-place-frame-overlay, guile-turn-off-frame-overlay, - guile-unselect-stackframe): New functions. - (guile-unselect-stackframe): Turn off overlay and set - guile-selected-frame to nil. - (guile-stack-frame): New overlay category. - (guile-selected-frame): defun --> defvar - (guile-exit-debug): Turn off frame overlay. - (guile-prep-backtrace): Call `guile-unselect-stackframe'. - (guile-turn-off-sexp-overlay, guile-turn-off-frame-overlay): Check - (car args) before applying `delete-overlay'. - (guile-error-map): Bind S-mouse-2 to guile-frame-eval-at-click. - - * inda-scheme.el (inda-scheme-mode-initializations): Bind - S-mouse-2 to guile-frame-eval-at-click; Bind M-TAB to - guile-complete-symbol. - - * guile.el (guile-complete-symbol): Made a command. - (guile-frame-eval-at-click, guile-frame-eval): New functions. - Enables clicking on expressions in the source buffer to show their - values. - (guile-complete-symbol, guile-list-completions): Bugfix: Use - `buffer-name' instead of `current-buffer' in order to obtain the - buffer name. - (guile-select-frame): Always set guile-selected-frame. - -Mon Aug 25 16:21:18 1997 Mikael Djurfeldt - - * guile.el (guile-eval): Must wait for scheme-ready-p so that the - filter functions don't get called. - (guile-describe-variable): Put `guile-force-splittable' around - call to `with-output-to-temp-buffer' so that documentation can be - displayed also in *scheme* window even if it is dedicated. - -Sun Aug 24 22:19:16 1997 Mikael Djurfeldt - - * *** Transferred code to guile-emacs. *** - - * inda-scheme.el (inda-inferior-initializations): Removed - assignment to scheme-pop-to-buffer. - -Thu Aug 21 01:47:31 1997 Mikael Djurfeldt - - * guile.el (guile-eval-result, guile-receive-result, guile-eval): - guile-eval-result now contains the printed representation as a - string instead of an elisp object. - (guile-eval-output): New variable. - (guile-receive-result): Set guile-eval-output to - guile-unallowed-output. - (guile-define-startcol, guile-define-filler, - guile-define-fillcol): New variables. Buffer-local. - (guile-define-header-emitted-p): New variable. - (scheme-send-region): Print result of last sent overlay or show - message "Defined." if definitions have been made. - (guile-insert-before-prompt): Don't use guile-pre-prompt-marker. - (guile-pre-prompt-marker): New name: guile-define-name-marker. - (guile-send-region): Moved printing of defined names to - guile-display-name. - (guile-send-overlay): New parameters; Zeros guile-eval-output; - Adapted to new format of %%emacs-load; Can now send sub-parts of - an overlay; Use guile-display-name. - (guile-display-name): New function. - (guile-receive-result): Reset guile-unallowed-output after having - stored its value in guile-eval-output. - -Sat Aug 16 02:53:00 1997 Mikael Djurfeldt - - * guile.el (guile-display-error): Limit height of *Scheme Error* - window to half of guile-backtrace-max-height. - -Thu Jul 24 18:41:56 1997 Mikael Djurfeldt - - * guile.el (guile-normal-edit): Don't set - scheme-buffer-modified-p. This will be done by - guile-scheme-buffer-modified next time the buffer is modified. - (guile-scheme-buffer-modified): New function. - (guile-inferior-initialize): Make first-change-hook buffer-local, - add guile-scheme-modified; Pass t for initialp to - guile-enhanced-edit if the scheme-buffer seems untouched. - - * guile.el (guile-normal-edit): Unlink overlays and buffer. - - * inda-scheme.el (inda-send-definition, inda-mark-sexp): Make it - possible to send expressions to scheme just by clicking on them. - - * guileint.el: Removed statements that doesn't have anything to do - with the Guile interface per se (transient-mark-mode, iso-syntax - etc) - -Wed Jul 23 19:11:15 1997 Mikael Djurfeldt - - * inda-scheme.el: Changed inda menu --> interpret. - -Thu Jul 17 10:43:58 1997 Mikael Djurfeldt - - * inda96.el (devel-binary): Changed to unstable. - - * guile.el (guile-display-buffers): Check for window system before - deleting windows on buffer1. - (guile-get-create-error-window): Treat non-window system - differently. - (scheme-send-region): Don't check for (scheme-ready-p) here. This - is checked in guile-send-region. - (guile-send-region): Check for (scheme-ready-p) here instead. - Go to end-of-buffer before determining proper place for "DEFINED - %s (". - -Tue Oct 15 16:56:18 1996 Mikael Djurfeldt - - * Start of revision history for misc elisp files. - rmfile ./site-lisp/guileint-1.5/ChangeLog hunk ./site-lisp/guileint-1.5/INSTALL 1 -Requirements -============ - -* Emacs 21.2 - -* Guile 1.3 or higher, compiled with threads - -Installation instructions -========================= - -1. export SCHEME_PROGRAM_NAME= - - or - - Put - - (setq scheme-program-name " --emacs") - - in your ".emacs". - -2. Add this directory to your load path. - You can do this by adding - - (setq load-path (cons "" load-path)) - - to your .emacs. - -3. Put - - (require 'guileint) - - in your ".emacs". - -4. Activate Guile debugging by evaluating the following expressions - at the Guile prompt (or put them in your ".guile") - - (debug-enable 'debug) - (read-enable 'positions) rmfile ./site-lisp/guileint-1.5/INSTALL hunk ./site-lisp/guileint-1.5/README 1 -Guile-Emacs interface -===================== - -This is version 1.5 of an Emacs interaction mode for running the Guile -Scheme interpreter. (The Guile side of the interface resides in -ice-9/emacs.scm.) - -It was originally part of a Guile-based course environment at KTH, -Stockholm. - -Disclaimer ----------- - -The core of this code was thrown together in a few days and was never -intended as more than a prototype. It has then evolved through -patching to quickly fix problems or adding new features and has for a -very long time been a playground for miscellaneous wild ideas. The -quality of the code reflects this. - -Features --------- - -1. Automatic displaying (and highlighting) of erring expression in - source buffer. - -2. Tracking of source expressions in the source buffer so that - scheme:s view of source positions can be translated into actual - position which may be different due to recent editing in the - buffer. - -3. Errors and backtraces come up in separate buffers. (This keeps the - interaction buffer cleaner, and it's easier to see what you've - written before.) - -4. The part of the interaction buffer above the prompt line is write - protected. The motivation is to enforce a correct dialog history. - -5. Typing things in the interaction buffer while point is above the - prompt line moves point to prompt line. - -6. Previous expressions in the interaction buffer are clickable. - Clicking reenters the expression to the interpreter. Clicking - with shift copies the expression to the prompt line. - -7. Backtraces are clickable so that klicking on a certain frame - highlights the corresponding expression in the source buffer. - -8. Clicking on a variable in a backtrace displays it's value in - the echo area. - -9. The users input and the computers answer has different faces. - -10. Incomplete expressions in scheme buffers has a special face. - -11. Probably several more features which I haven't documented here - yet... - -Planned features ----------------- - -12. When single stepping through code, the current expression should - be highlighted in the source buffer. - -Short notes on how to run it ----------------------------- - -Choose "Guile" in the "Interpret" menu. - -Then you should get a scheme window with a running Guile. - -First try typing something erroneous. - -You should get an error + backtrace window. -You can exit this with `q' or ESC. - -Then try opening a scheme file, e. g. "foo.scm". -Type in something, e. g., - -(define (fac x) - (if (= x 0) - (koko) - (* x (fac (1- x))))) - -Choose "Eval buffer" from the menu, then type "(foo 3)" in -the scheme interpreter window. - -Your scheme buffer ("foo.scm") should now pop up, split into three -sections, and the expression "(koko)" should be marked in red. - -Again, typing `q' or ESC *in the error or backtrace window* will -remove these windows. - -Now try out the different items in the Scheme buffer "Scheme" menu. -If you go to the buffer "foo.scm" and select "Attach buffer" in the -menu, all changes to definitions in that buffer will be automagically -transfered to scheme. So, the illusion produced is that typing in the -"foo.scm" buffer is like typing into scheme memory. - -This illusion breaks down, however, if the scheme buffer contains -other stuff than procedure definitions... - -Code ----- - -The two main components are: - -* Code that can track positions of expressions in a source buffer - while editing. It maintains overlays over each top-level - expression, and can create new ones and delete old ones on the fly. - -* An extension to comint so that it gets a dispatching I/O multiplexer - similar to the one in xscheme.el. - -Most things are in "guile.el". - -Some setups + additional code is done by init-file-like files like -"guile-init.el". These are relics from the two first days of the -interface's life when it still had something reminiscent of -structure... ;-) - -Files with the same names as files in the Emacs distribution is slight -modifications of the correspondees. I originally planned to try -getting these included in Emacs. - -The following changes have been made to files from the Emacs distribution: - -cmuscheme.el: - -1. New buffer local variable: - - inferior-scheme-mode-line-process - -2. The variable - - scheme-buffer - -has been replaced by the buffer local variable - - inferior-scheme-associated-buffers - -3. mode-line-process has been changed to use - - inferior-scheme-mode-line-process - -comint.el: - -1. New buffer local variables: - - comint-unallowed-output-filter-functions - comint-output-filter-function - comint-allow-output-p - comint-dispatch-state - comint-string-accumulator - comint-string-receiver - comint-receiving-buffer - comint-buffer-receiver - -2. Patch to comint-exec - -Use comint-output-filter-function instead of comint-output-filter. - -3. Patch to comint-output-filter. - -4. New functions: - - comint-insert-output - comint-dispatch-filter-initialize - comint-dispatch-output-filter - -5. New variables: - - comint-dispatch-escape-character - comint-dispatch-string-end-regexp - comint-dispatch-buffer-end-regexp - comint-dispatch-alist - -Debugging ---------- - -If you do - - M-x guile-show-overlays - -in a scheme source buffer, the interface will show how it interprets -the expressions in the buffer (and how it tracks them, when they are -modified). - -Shut it off with - - M-x guile-hide-overlays - -I use *pairs* of colors for denoting each meaning. This is so that -you can distinguish adjacent overlays from eachother. - -Colors mean: - -dark/light blue: expressions are unmodified since last sent to Guile - -green/pink: expressions have been modified - -underlined: expressions are "broken" (which means that they can't be - sent to Guile) rmfile ./site-lisp/guileint-1.5/README hunk ./site-lisp/guileint-1.5/TAGS 1 - -cmuscheme.el,1589 -(defvar inferior-scheme-mode-hook 76,3252 -(defvar inferior-scheme-mode-map 78,3339 -(define-key scheme-mode-map 91,3960 -(define-key scheme-mode-map 92,4038 -(define-key scheme-mode-map 93,4116 -(define-key scheme-mode-map 94,4180 -(define-key scheme-mode-map 95,4251 -(define-key scheme-mode-map 96,4311 -(define-key scheme-mode-map 97,4378 -(define-key scheme-mode-map 98,4445 -(define-key scheme-mode-map 99,4519 -(define-key scheme-mode-map 100,4577 -(define-key scheme-mode-map 101,4635 -(defvar inferior-scheme-mode-line-process 103,4714 -(defvar inferior-scheme-associated-buffers 105,4766 -(defun inferior-scheme-mode 107,4815 -(defvar inferior-scheme-filter-regexp 159,7186 -(defun scheme-input-filter 163,7386 -(defun scheme-get-old-input 167,7541 -(defun scheme-args-to-list 174,7713 -(defvar scheme-program-name 187,8135 -(defun run-scheme 191,8236 -(defun scheme-send-region 212,9148 -(defun scheme-send-definition 218,9357 -(defun scheme-send-last-sexp 227,9598 -(defvar scheme-compile-exp-command 232,9779 -(defun scheme-compile-region 235,9908 -(defun scheme-compile-definition 244,10277 -(defun switch-to-scheme 253,10527 -(defun scheme-send-region-and-go 264,10870 -(defun scheme-send-definition-and-go 271,11088 -(defun scheme-compile-definition-and-go 278,11288 -(defun scheme-compile-region-and-go 285,11497 -(defvar scheme-source-modes 292,11717 -(defvar scheme-prev-l/c-dir/file 298,12020 -(defun scheme-load-file 304,12242 -(defun scheme-compile-file 316,12833 -(defvar scheme-buffer 331,13449 -(defun scheme-proc 371,15465 -(defvar cmuscheme-load-hook 382,15798 - -comint.el,5691 -(defvar comint-prompt-regexp 142,6595 -(defvar comint-delimiter-argument-list 156,7036 -(defvar comint-input-autoexpand 167,7468 -(defvar comint-input-ignoredups 178,7907 -(defvar comint-input-ring-file-name 184,8091 -(defvar comint-scroll-to-bottom-on-input 190,8335 -(defvar comint-scroll-to-bottom-on-output 199,8667 -(defvar comint-scroll-show-maximum-output 210,9123 -(defvar comint-buffer-maximum-size 217,9436 -(defvar comint-input-ring-size 222,9687 -(defvar comint-process-echoes 225,9755 -(defvar comint-password-prompt-regexp232,9977 -(defvar comint-get-old-input 238,10248 -(defvar comint-dynamic-complete-functions245,10640 -(defvar comint-input-filter253,10950 -(defvar comint-input-filter-functions 259,11253 -(defvar comint-output-filter-function 265,11460 -(defvar comint-output-filter-functions 275,11889 -(defvar comint-allow-output-p 285,12404 -(defvar comint-unallowed-output-filter-functions 288,12495 -(defvar comint-dispatch-state 292,12650 -(defvar comint-string-accumulator 298,12906 -(defvar comint-string-receiver 301,13009 -(defvar comint-receiving-buffer 304,13106 -(defvar comint-buffer-receiver 306,13144 -(defvar comint-input-sender 308,13181 -(defvar comint-eol-on-send 315,13556 -(defvar comint-mode-hook 319,13679 -(defvar comint-exec-hook 323,13795 -(defvar comint-mode-map 330,14159 -(defvar comint-ptyp 332,14189 -(defvar comint-input-ring 336,14342 -(defvar comint-last-input-start)337,14373 -(defvar comint-last-input-end)338,14406 -(defvar comint-last-output-start)339,14437 -(defvar comint-input-ring-index 340,14471 -(defvar comint-matching-input-from-input-string 342,14551 -(defun comint-mode 358,15332 -(defun comint-check-proc 547,25194 -(defun make-comint 557,25639 -(defun comint-run 580,26817 -(defun comint-exec 591,27330 -(defun comint-exec-1 632,29080 -(defun comint-read-input-ring 678,31141 -(defun comint-write-input-ring 727,33024 -(defun comint-dynamic-list-input-ring 759,34253 -(defun comint-regexp-arg 789,35310 -(defun comint-search-arg 802,35800 -(defun comint-search-start 816,36214 -(defun comint-previous-input-string 827,36727 -(defun comint-previous-input 835,37027 -(defun comint-next-input 840,37171 -(defun comint-previous-matching-input-string 845,37301 -(defun comint-previous-matching-input-string-position 851,37600 -(defun comint-previous-matching-input 878,38797 -(defun comint-next-matching-input 896,39610 -(defun comint-previous-matching-input-from-input 904,40009 -(defun comint-next-matching-input-from-input 922,40777 -(defun comint-replace-by-expanded-history 931,41152 -(defun comint-replace-by-expanded-history-before-point 960,42382 -(defun comint-magic-space 1050,46141 -(defun comint-within-quotes 1057,46411 -(defun comint-how-many-region 1064,46740 -(defun comint-args 1074,47007 -(defun comint-delim-arg 1095,47922 -(defun comint-arguments 1114,48470 -(defun comint-send-input 1157,50012 -(defun comint-output-filter 1247,54099 -(defun comint-insert-output 1256,54398 -(defun comint-dispatch-filter-initialize 1292,55667 -(defun comint-dispatch-output-filter 1295,55750 -(defvar comint-dispatch-escape-character 1372,58218 -(defvar comint-dispatch-string-end-regexp 1376,58374 -(defvar comint-dispatch-buffer-end-regexp 1378,58428 -(defvar comint-dispatch-alist 1380,58482 -(defun comint-preinput-scroll-to-bottom 1395,59194 -(defun comint-postoutput-scroll-to-bottom 1423,60317 -(defun comint-truncate-buffer 1460,61719 -(defun comint-strip-ctrl-m 1470,62123 -(defalias 'shell-strip-ctrl-m 1480,62588 -(defun comint-show-maximum-output 1482,62641 -(defun comint-get-old-input-default 1488,62797 -(defun comint-copy-old-input 1499,63114 -(defun comint-skip-prompt 1510,63506 -(defun comint-after-pmark-p 1518,63830 -(defun comint-simple-send 1523,64033 -(defun comint-bol 1530,64291 -(defun comint-read-noecho 1545,64945 -(defun send-invisible 1595,66918 -(defun comint-watch-for-password-prompt 1608,67458 -(defalias 'comint-send-string 1620,67941 -(defalias 'comint-send-region 1621,67993 -(defun comint-kill-output 1625,68072 -(defun comint-show-output 1643,68715 -(defun comint-interrupt-subjob 1654,69103 -(defun comint-kill-subjob 1659,69227 -(defun comint-quit-subjob 1664,69351 -(defun comint-stop-subjob 1669,69475 -(defun comint-continue-subjob 1678,69851 -(defun comint-kill-input 1684,70053 -(defun comint-delchar-or-maybe-eof 1691,70310 -(defun comint-send-eof 1698,70511 -(defun comint-backward-matching-input 1704,70626 -(defun comint-forward-matching-input 1720,71273 -(defun comint-next-prompt 1729,71688 -(defun comint-previous-prompt 1738,71953 -(defun comint-source-default 1806,75313 -(defun comint-check-source 1823,76042 -(defun comint-extract-string 1856,77487 -(defun comint-get-source 1871,77980 -(defun comint-proc-query 1915,80009 -(defvar comint-completion-autolist 1958,81969 -(defvar comint-completion-addsuffix 1962,82127 -(defvar comint-completion-recexact 1968,82434 -(defvar comint-completion-fignore 1974,82666 -(defvar comint-file-name-prefix 1980,82891 -(defvar comint-file-name-chars1985,83102 -(defvar comint-file-name-quote-list 1993,83340 -(defun comint-directory 1999,83490 -(defun comint-word 2006,83728 -(defun comint-substitute-in-file-name 2024,84534 -(defun comint-match-partial-filename 2042,85229 -(defun comint-quote-filename 2050,85540 -(defun comint-unquote-filename 2063,86015 -(defun comint-dynamic-complete 2075,86372 -(defun comint-dynamic-complete-filename 2084,86712 -(defun comint-dynamic-complete-as-filename 2107,87759 -(defun comint-replace-by-expanded-filename 2161,90649 -(defun comint-dynamic-simple-complete 2174,91308 -(defun comint-dynamic-list-filename-completions 2225,93421 -(defun comint-dynamic-list-completions 2244,94324 - -defmenu.el,85 -(defun define-menu 38,1167 -(defun make-menu 57,1923 -(defun defmenu-gensym 88,3104 - -guess-mode.el,484 -(defvar guess-mode-load-hook 38,1175 -(defvar gm-check-contents-interval 43,1280 -(defvar gm-check-contents-maxsize 45,1320 -(defvar gm-check-contents-tick-limit 47,1361 -(defvar gm-check-modes 50,1461 -(defvar gm-guess-mode-alist52,1528 -(defun gm-check-contents-hook-function 57,1698 -(defun gm-check-contents 66,1992 -(defun gm-guess-mode 105,3229 -(defconst gm-extension-regexp-regexp120,3592 -(defun gm-make-extension-string 123,3685 -(defun gm-make-enumeration-string 138,4168 - -guile-init.el,612 -(defvar guile-init-load-hook 38,1100 -(defun inda-barf-at-modifications 46,1219 -(defun inda-boldify-previous-character 50,1342 -(defun inda-make-input-memory 56,1569 -(defun inda-reset-guile-last-output 66,2032 -(define-key inferior-scheme-mode-map 72,2231 -(define-key inferior-scheme-mode-map 73,2305 -(defun inda-mouse-yank-at-click 76,2427 -(defun inda-insert-input-memory 93,3188 -(defun inda-insert-input-memory-and-send 107,3665 -(defun inda-boldify 112,3792 -(defun inda-extend-read-only-overlay 115,3889 -(defun scheme-send-buffer 122,4082 -(defun indent-buffer 133,4384 -(defun indent-defun 142,4579 - -guile.el,8405 -(defvar guile-auto-attach 44,1469 -(defvar guile-load-hook 46,1501 -(defvar guile-error-face 57,1847 -(defvar guile-backtrace-mouse-face 60,1929 -(defvar guile-modified-face 63,2026 -(defvar guile-broken-face 66,2122 -(defvar guile-unmodified-face-1 71,2282 -(defvar guile-unmodified-face-2 72,2319 -(defvar guile-modified-face-1 73,2356 -(defvar guile-modified-face-2 74,2391 -(defvar guile-broken-face-1 75,2426 -(defvar guile-broken-face-2 76,2459 -(defvar guile-backtrace-in-source-window 81,2516 -(defvar guile-show-runlight-in-scheme-mode 85,2693 -(defvar guile-default-enhanced-edit 89,2881 -(defvar guile-popup-restart-on-death 92,2996 -(defvar guile-popup-restart-on-stop 94,3037 -(defvar guile-insert-reason 96,3077 -(defvar guile-kill-buffer-on-death 98,3109 -(defvar guile-process-timeout 100,3150 -(defconst guile-backtrace-buffer-name 103,3203 -(defconst guile-error-buffer-name 105,3264 -(defconst guile-backtrace-min-height 107,3317 -(defconst guile-backtrace-max-height 108,3358 -(defconst guile-backtrace-min-width 109,3399 -(defconst guile-backtrace-max-width 110,3439 -(defconst guile-symclash-obarray-size 165,5712 -(defconst guile-big-integer 167,5756 -(defvar guile-inferior-scheme-frame 172,5822 -(defun guile-inferior-initialize 176,5891 -(defvar default-handle-switch-frame-binding223,7682 -(define-key global-map 225,7768 -(defun guile-handle-switch-frame 227,7835 -(defun guile-sync-on-input 234,8060 -(defvar guile-unallowed-output 250,8563 -(defun guile-remember-unallowed-output 252,8600 -(defvar scheme-buffer-overlays 261,8854 -(defvar scheme-buffer-last-overlay 265,9030 -(defvar scheme-buffer-modified-p 269,9149 -(defvar scheme-buffer-overlays-modified-p 272,9261 -(defvar scheme-associated-process-buffer 274,9309 -(defvar scheme-overlay-repair-function 278,9480 -(defvar scheme-overlay-repair-idle-timer 282,9587 -(defun guile-scheme-mode-initialize 284,9634 -(defun guile-scheme-buffer-modified 307,10595 -(defun guile-scheme-mode-cleanup 310,10672 -(defun guile-clear-transcript 321,10961 -(defun guile-switch-to-scheme 336,11527 -(defvar scheme-ready-p 350,11961 -(defvar scheme-load-p 353,12062 -(defvar guile-no-stack-p 355,12090 -(defvar guile-no-source-p 357,12121 -(defun guile-inferior-dialog 359,12153 -(defun guile-sentinel 363,12279 -(defun guile-inferior-death-cleanup 394,13337 -(defun run-scheme 404,13704 -(defun guile-restart-scheme 428,14753 -(defun guile-shutdown 447,15323 -(defun guile-exit-scheme 473,16066 -(defun scheme:simple-action 494,16807 -(defun scheme:string-action 498,16902 -(defun scheme:buffer-action 503,17065 -(defun guile-no-stack 510,17289 -(defun guile-no-source 513,17344 -(defvar guile-eval-result 516,17401 -(defvar guile-eval-output 517,17432 -(defun guile-receive-result 519,17464 -(defun guile-eval 525,17658 -(defun scheme-set-runlight 542,18254 -(defconst scheme-runlight:running 557,18753 -(defconst scheme-runlight:input 560,18860 -(defconst scheme-runlight:read 563,18976 -(defconst scheme-runlight:load 566,19091 -(defvar guile-last-output-end)569,19204 -(defun scheme-enter-input-wait 572,19251 -(defun guile-on-error 594,19995 -(defun scheme-exit-input-wait 602,20225 -(defun scheme-enter-read 607,20364 -(defun scheme-enter-load 612,20497 -(defun scheme-load-acknowledge 617,20625 -(defvar guile-error-p 622,20726 -(defvar guile-last-displayed-position 624,20754 -(defvar guile-positional-reliability 626,20798 -(defvar guile-last-erring-overlay 628,20841 -(defvar guile-sexp-overlay 630,20881 -(defvar guile-frame-overlay 632,20914 -(defconst guile-position-regexp636,21049 -(defconst guile-position-regexp-line 639,21125 -(defconst guile-position-regexp-column 640,21165 -(defconst guile-position-regexp-filename 641,21207 -(defvar guile-error-width 643,21252 -(defvar guile-backtrace-length 644,21281 -(defvar guile-backtrace-width 645,21317 -(defvar guile-error-map 647,21351 -(defvar guile-stack-frame-map 660,21890 -(defun guile-exit-debug 671,22216 -(defun guile-receive-backtrace 682,22521 -(defun guile-prep-backtrace 695,22943 -(defvar guile-selected-frame 728,23954 -(defun guile-select-stackframe 730,23989 -(defun guile-unselect-stackframe 754,24901 -(defun guile-frame-eval 758,25006 -(defun guile-frame-eval-at-click 772,25519 -(defun guile-receive-error 781,25752 -(defvar guile-source-window 808,26619 -(defun guile-display-error 810,26653 -(defun guile-display-buffers 890,29326 -(defvar guile-error-frame 928,30625 -(defun guile-get-create-error-window 930,30657 -(defun guile-display-scheme-sexp 946,31248 -(defun guile-display-sexp 984,32718 -(defun guile-display-sexp-at-point 1013,33807 -(defun guile-place-frame-overlay 1047,34977 -(defun guile-turn-off-sexp-overlay 1054,35312 -(defun guile-turn-off-frame-overlay 1059,35500 -(defun guile-display-position 1064,35691 -(defun guile-goto-position 1082,36339 -(defun guile-get-file-buffer 1092,36622 -(defun guile-attachedp 1095,36693 -(defun guile-attach-buffer 1102,36866 -(defun guile-dont-attach-buffer 1137,38202 -(defun guile-detach-buffer 1171,39491 -(defun guile-detach-all 1193,40314 -(defvar scheme-virtual-file-list 1211,40948 -(defvar guile-synchronizedp 1213,40987 -(defvar guile-last-virtual-id 1215,41019 -(defun guile-synchronizedp 1217,41053 -(defun guile-alloc-virtual-id 1221,41117 -(defun guile-virtual-p 1228,41377 -(defun guile-virtually-linked-p 1231,41446 -(defun guile-virtual-link 1234,41527 -(defun scheme-virtual-unlink 1245,41862 -(defun guile-load-file 1251,42049 -(defun guile-reread-buffer 1276,43067 -(defun guile-get-associated-buffers 1290,43527 -(defvar guile-symclash-obarray 1295,43657 -(defun guile-reset-symclash-obarray 1297,43734 -(defvar guile-displayed-erring-buffers 1300,43833 -(defvar guile-quiet 1301,43877 -(defun guile-check-all 1303,43901 -(defun guile-check-all-1 1308,43990 -(defun guile-check-buffer 1331,44738 -(defun guile-show-check-error 1341,45012 -(defvar guile-last-displayed-erring-overlay 1360,45642 -(defun guile-check-buffer-1 1362,45692 -(defconst guile-defexpr 1372,45968 -(defconst guile-defexpr-name 1373,46058 -(defun guile-check-overlay 1375,46091 -(defun guile-sync-with-scheme 1401,46945 -(defun guile-sync-buffer 1422,47586 -(defun guile-sync-buffer-1 1427,47711 -(defun guile-alloc-finfo 1468,49219 -(defun guile-new-finfo 1486,49762 -(defvar guile-last-prompt-end 1497,50141 -(defvar guile-input-sent-p 1498,50176 -(defun guile-send-input 1500,50207 -(defconst guile-whitespace-chars 1520,50802 -(defun guile-whitespace-between-p 1522,50849 -(defun guile-send-changes 1534,51244 -(defun scheme-send-region 1557,51892 -(defvar guile-define-name-marker)1576,52541 -(defun guile-insert-before-prompt 1578,52576 -(defvar guile-define-header-emitted-p 1599,53223 -(defvar guile-define-startcol 1600,53266 -(defvar guile-define-filler 1601,53299 -(defvar guile-define-fillcol 1602,53331 -(defvar guile-last-result 1603,53363 -(defun guile-send-region 1605,53395 -(defconst guile-end-of-chunk 1635,54465 -(defun guile-send-overlay 1638,54530 -(defun guile-display-name 1725,57413 -(defvar guile-n-enhanced-buffers 1768,58741 -(defun guile-enhancedp 1771,58823 -(defun guile-get-enhanced-buffers 1779,59008 -(defun guile-enhanced-edit 1788,59217 -(defun guile-normal-edit 1804,59913 -(defun guile-current-line 1833,61028 -(defun guile-safe-forward-sexp 1837,61126 -(defun guile-safe-backward-sexp 1844,61303 -(defun guile-parse-buffer 1851,61482 -(defvar guile-tail-cons 1866,62063 -(defun guile-cons-before-match 1868,62104 -(defun guile-reparse-buffer 1882,62472 -(defvar guile-last-broken 2073,69132 -(defvar guile-repair-limit 2074,69163 -(defun guile-handle-modification 2076,69210 -(defun guile-repair-overlays 2100,70052 -(defun guile-backward-broken-sexp 2112,70437 -(defun rear-sticky-overlay-function 2132,70964 -(defvar guile-show-overlays-p 2139,71146 -(defun guile-show-overlays 2141,71182 -(defun guile-hide-overlays 2190,72670 -(defun guile-kill-overlays 2204,73043 -(defun overlay-kill 2217,73371 -(defun for-each 2221,73459 -(defconst guile-symbol-chars 2229,73568 -(defun guile-match-symnames 2231,73637 -(defmacro guile-force-splittable 2242,73905 -(defvar guile-complete-function 2258,74470 -(defun guile-indent-or-complete 2260,74529 -(defun guile-complete-symbol 2269,74780 -(defun guile-list-completions 2280,75124 -(defun guile-documentation-symbols 2295,75656 -(defun guile-variable-at-point 2300,75809 -(defun guile-describe-variable 2316,76346 - -guileint.el,187 -(defconst guileint-init-file 29,738 -(defvar guileint-emacs-dir 31,780 -(defvar guileint-default-load-path 40,1061 -(defun restore-blink-paren 104,3044 -(define-menu global-map 121,3371 - -hilit-scheme.el,0 - -inda-c.el,83 -(defvar inda-c-menu-fixed-p 44,1133 -(defun inda-c-mode-common-initialize 47,1196 - -inda-scheme.el,461 -(defun inda-scheme-mode-initializations 31,811 -(defun scheme-electric-open-paren 59,2234 -(defun scheme-close-paren 67,2456 -(defun inda-send-definition 75,2650 -(defun inda-mark-sexp 82,2846 -(defvar inda-read-only-overlay 87,2926 -(defun inda-inferior-initializations 89,2963 -(define-menu scheme-mode-map 159,5705 -(define-menu inferior-scheme-mode-map 188,6815 -(define-key inferior-scheme-mode-map 201,7427 -(define-key inferior-scheme-mode-map 202,7497 - -scheme.el,949 -(defvar scheme-mode-syntax-table 34,1231 -(defvar scheme-mode-abbrev-table 88,2829 -(define-abbrev-table 'scheme-mode-abbrev-table 89,2870 -(defvar scheme-mode-line-process 91,2922 -(defvar scheme-associated-process-buffer 93,2961 -(defun scheme-mode-variables 95,3008 -(defun scheme-mode-commands 126,4399 -(defvar scheme-mode-map 131,4584 -(defun scheme-mode 138,4764 -(defun scheme-mode-initialize 161,5636 -(defvar scheme-mit-dialect 166,5766 -(defun scheme-comment-indent 170,5910 -(defvar scheme-indent-offset 182,6260 -(defvar scheme-indent-function 183,6297 -(defun scheme-indent-line 185,6357 -(defun calculate-scheme-indent 220,7567 -(defun scheme-indent-function 306,11151 -(defvar scheme-body-indent 327,11995 -(defun scheme-indent-specform 329,12030 -(defun scheme-indent-defform 368,13634 -(defun would-be-symbol 378,13899 -(defun next-sexp-as-string 381,13983 -(defun scheme-let-indent 395,14449 -(defun scheme-indent-sexp 466,17752 - -xscheme.el,4262 -(defvar scheme-program-name 35,1122 -(defvar scheme-band-name 38,1211 -(defvar scheme-program-arguments 41,1288 -(defvar xscheme-allow-pipelined-evaluation 44,1400 -(defvar xscheme-startup-message49,1650 -(defvar xscheme-signal-death-message 59,2052 -(defun xscheme-evaluation-commands 62,2174 -(defun xscheme-interrupt-commands 70,2573 -(defun run-scheme 80,3044 -(defun reset-scheme 94,3517 -(defun xscheme-default-command-line 107,3994 -(defun scheme-interaction-mode 118,4266 -(defun scheme-interaction-mode-initialize 197,7776 -(defun scheme-interaction-mode-commands 202,7954 -(defvar scheme-interaction-mode-map 207,8181 -(defun xscheme-enter-interaction-mode 216,8582 -(defun scheme-debugger-mode 229,8973 -(defun scheme-debugger-mode-initialize 240,9376 -(defun scheme-debugger-mode-commands 245,9542 -(defvar scheme-debugger-mode-map 251,9740 -(defun scheme-debugger-self-insert 259,10056 -(defun xscheme-enter-debugger-mode 264,10203 -(defun xscheme-debugger-mode-p 273,10504 -(defun xscheme-send-string 282,10713 -(defun xscheme-send-string-1 299,11404 -(defun xscheme-send-string-2 305,11610 -(defun xscheme-yank-previous-send 311,11829 -(defun xscheme-select-process-buffer 317,11979 -(defun xscheme-send-region 328,12418 -(defun xscheme-send-definition 337,12760 -(defun xscheme-send-next-expression 351,13241 -(defun xscheme-send-previous-expression 357,13467 -(defun xscheme-send-current-line 363,13694 -(defun xscheme-send-buffer 377,14064 -(defun xscheme-send-char 384,14322 -(defun xscheme-send-breakpoint-interrupt 391,14522 -(defun xscheme-send-proceed 396,14670 -(defun xscheme-send-control-g-interrupt 401,14817 -(defun xscheme-send-control-u-interrupt 416,15330 -(defun xscheme-send-control-x-interrupt 421,15493 -(defun xscheme-send-interrupt 431,15906 -(defvar xscheme-process-command-line 441,16256 -(defvar xscheme-previous-send 444,16357 -(defvar xscheme-process-filter-state 447,16454 -(defvar xscheme-running-p 453,16715 -(defconst xscheme-control-g-synchronization-p 457,16875 -(defvar xscheme-control-g-disabled-p 462,17131 -(defvar xscheme-allow-output-p 466,17319 -(defvar xscheme-prompt 470,17466 -(defvar xscheme-string-accumulator 473,17532 -(defvar xscheme-string-receiver 476,17643 -(defvar xscheme-start-hook 479,17748 -(defvar xscheme-runlight-string 483,17920 -(defvar xscheme-mode-string 484,17957 -(defvar xscheme-filter-input 485,17990 -(defun xscheme-start-process 489,18054 -(defun xscheme-parse-command-line 517,19071 -(defun xscheme-wait-for-process 538,19595 -(defun xscheme-process-running-p 543,19694 -(defun xscheme-process-buffer 549,19892 -(defun xscheme-process-buffer-window 553,20013 -(defun xscheme-process-buffer-current-p 557,20143 -(defun xscheme-process-sentinel 563,20321 -(defun xscheme-process-filter-initialize 576,20768 -(defun xscheme-process-filter 584,21073 -(defun xscheme-process-filter-output 631,22872 -(defun xscheme-guarantee-newlines 649,23458 -(defun xscheme-goto-output-point 665,23811 -(defun xscheme-modeline-initialize 670,23973 -(defun xscheme-set-runlight 675,24156 -(defvar xscheme-process-filter-alist681,24301 -(defun xscheme-process-filter:simple-action 732,26282 -(defun xscheme-process-filter:string-action 736,26400 -(defconst xscheme-runlight:running 741,26588 -(defconst xscheme-runlight:input 744,26695 -(defconst xscheme-runlight:gc 747,26812 -(defun xscheme-start-gc 750,26924 -(defun xscheme-finish-gc 753,26998 -(defun xscheme-enter-input-wait 757,27127 -(defun xscheme-exit-input-wait 761,27243 -(defun xscheme-enable-control-g 765,27358 -(defun xscheme-display-process-buffer 768,27437 -(defun xscheme-unsolicited-read-char 777,27748 -(defun xscheme-eval 780,27797 -(defun xscheme-message 783,27869 -(defun xscheme-write-value 787,28001 -(defun xscheme-write-message-1 792,28195 -(defun xscheme-set-prompt-variable 802,28572 -(defun xscheme-set-prompt 805,28649 -(defun xscheme-output-goto 811,28839 -(defun xscheme-coerce-prompt 815,28934 -(defvar xscheme-prompt-alist826,29236 -(defun xscheme-cd 835,29595 -(defun xscheme-prompt-for-confirmation 840,29722 -(defun xscheme-prompt-for-expression 843,29837 -(defvar xscheme-prompt-for-expression-map 847,29996 -(defun xscheme-prompt-for-expression-exit 856,30319 -(defun xscheme-region-expression-p 862,30537 rmfile ./site-lisp/guileint-1.5/TAGS hunk ./site-lisp/guileint-1.5/cmuscheme.el 1 -;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el - -;; Copyright (C) 1988, 1994, 1997 Free Software Foundation, Inc. - -;; Author: Olin Shivers -;; Maintainer: FSF -;; Keywords: processes, lisp - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This is a customisation of comint-mode (see comint.el) -;; -;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces -;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al.. -;; 8/88 -;; -;; Please send me bug reports, bug fixes, and extensions, so that I can -;; merge them into the master source. -;; -;; The changelog is at the end of this file. -;; -;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user -;; interface that communicates process state back to the superior emacs by -;; outputting special control sequences. The gnumacs package, xscheme.el, has -;; lots and lots of special purpose code to read these control sequences, and -;; so is very tightly integrated with the cscheme process. The cscheme -;; interrupt handler and debugger read single character commands in cbreak -;; mode; when this happens, xscheme.el switches to special keymaps that bind -;; the single letter command keys to emacs functions that directly send the -;; character to the scheme process. Cmuscheme mode does *not* provide this -;; functionality. If you are a cscheme user, you may prefer to use the -;; xscheme.el/cscheme -emacs interaction. -;; -;; Here's a summary of the pros and cons, as I see them. -;; xscheme: Tightly integrated with inferior cscheme process! A few commands -;; not in cmuscheme. But. Integration is a bit of a hack. Input -;; history only keeps the immediately prior input. Bizarre -;; keybindings. -;; -;; cmuscheme: Not tightly integrated with inferior cscheme process. But. -;; Carefully integrated functionality with the entire suite of -;; comint-derived CMU process modes. Keybindings reminiscent of -;; Zwei and Hemlock. Good input history. A few commands not in -;; xscheme. -;; -;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme -;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very* -;; Cscheme-specific; you must use cmuscheme.el. Interested parties are -;; invited to port xscheme functionality on top of comint mode... - -;;; CHANGE LOG -;;; =========================================================================== -;;; 8/88 Olin -;;; Created. -;;; -;;; 2/15/89 Olin -;;; Removed -emacs flag from process invocation. It's only useful for -;;; cscheme, and makes cscheme assume it's running under xscheme.el, -;;; which messes things up royally. A bug. -;;; -;;; 5/22/90 Olin -;;; - Upgraded to use comint-send-string and comint-send-region. -;;; - run-scheme now offers to let you edit the command line if -;;; you invoke it with a prefix-arg. M-x scheme is redundant, and -;;; has been removed. -;;; - Explicit references to process "scheme" have been replaced with -;;; (scheme-proc). This allows better handling of multiple process bufs. -;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention. -;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist -;;; and friends, but interested hackers might find a useful application -;;; of this facility. -;;; -;;; 3/12/90 Olin -;;; - scheme-load-file and scheme-compile-file no longer switch-to-scheme -;;; Tale suggested this. - -;;; Code: - -(require 'scheme) -(require 'comint) - - -(defgroup cmuscheme nil - "Run a scheme process in a buffer." - :group 'scheme) - -;;; INFERIOR SCHEME MODE STUFF -;;;============================================================================ - -(defcustom inferior-scheme-mode-hook nil - "*Hook for customising inferior-scheme mode." - :type 'hook - :group 'cmuscheme) - -(defvar inferior-scheme-mode-map - (let ((m (make-sparse-keymap))) - (define-key m "\M-\C-x" 'scheme-send-definition) ;gnu convention - (define-key m "\C-x\C-e" 'scheme-send-last-sexp) - (define-key m "\C-c\C-l" 'scheme-load-file) - (define-key m "\C-c\C-k" 'scheme-compile-file) - (scheme-mode-commands m) - m)) - -;; Install the process communication commands in the scheme-mode keymap. -(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention -(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention -(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition) -(define-key scheme-mode-map "\C-c\M-e" 'scheme-send-definition-and-go) -(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region) -(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go) -(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition) -(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) -(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme) -(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file) -(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile" - -(let ((map (lookup-key scheme-mode-map [menu-bar scheme]))) - (define-key map [separator-eval] '("--")) - (define-key map [compile-file] - '("Compile Scheme File" . scheme-compile-file)) - (define-key map [load-file] - '("Load Scheme File" . scheme-load-file)) - (define-key map [switch] - '("Switch to Scheme" . switch-to-scheme)) - (define-key map [com-def-go] - '("Compile Definitiion & Go" . scheme-compile-definition-and-go)) - (define-key map [com-def] - '("Compile Definitiion" . scheme-compile-definition)) - (define-key map [send-def-go] - '("Evaluate Last Definition & Go" . scheme-send-definition-and-go)) - (define-key map [send-def] - '("Evaluate Last Definition" . scheme-send-definition)) - (define-key map [send-region-go] - '("Evaluate Region & Go" . scheme-send-region-and-go)) - (define-key map [send-region] - '("Evaluate Region" . scheme-send-region)) - (define-key map [send-sexp] - '("Evaluate Last S-expression" . scheme-send-last-sexp)) -) - -(defvar inferior-scheme-mode-line-process '("%s")) - -(defvar inferior-scheme-associated-buffers '()) - -(define-derived-mode inferior-scheme-mode comint-mode "Inferior Scheme" - "Major mode for interacting with an inferior Scheme process. - -The following commands are available: -\\{inferior-scheme-mode-map} - -A Scheme process can be fired up with M-x run-scheme. - -Customisation: Entry to this mode runs the hooks on comint-mode-hook and -inferior-scheme-mode-hook (in that order). - -You can send text to the inferior Scheme process from other buffers containing -Scheme source. - switch-to-scheme switches the current buffer to the Scheme process buffer. - scheme-send-definition sends the current definition to the Scheme process. - scheme-compile-definition compiles the current definition. - scheme-send-region sends the current region to the Scheme process. - scheme-compile-region compiles the current region. - - scheme-send-definition-and-go, scheme-compile-definition-and-go, - scheme-send-region-and-go, and scheme-compile-region-and-go - switch to the Scheme process buffer after sending their text. -For information on running multiple processes in multiple buffers, see -documentation for variable scheme-buffer. - -Commands: -Return after the end of the process' output sends the text from the - end of process to point. -Return before the end of the process' output copies the sexp ending at point - to the end of the process' output, and sends it. -Delete converts tabs to spaces as it moves back. -Tab indents for Scheme; with argument, shifts rest - of expression rigidly with the current line. -C-M-q does Tab on each line starting within following expression. -Paragraphs are separated only by blank lines. Semicolons start comments. -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - ;; Customise in inferior-scheme-mode-hook - (setq comint-prompt-regexp "^[^>\n]*>+ *") ; OK for cscheme, oaklisp, T,... - (scheme-mode-variables) - (make-local-variable 'inferior-scheme-mode-line-process) - (make-local-variable 'inferior-scheme-associated-buffers) - (setq mode-line-process '(":" inferior-scheme-mode-line-process)) - (setq comint-input-filter (function scheme-input-filter)) - (setq comint-get-old-input (function scheme-get-old-input))) - -(defcustom inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" - "*Input matching this regexp are not saved on the history list. -Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters." - :type 'regexp - :group 'cmuscheme) - -(defun scheme-input-filter (str) - "Don't save anything matching `inferior-scheme-filter-regexp'." - (not (string-match inferior-scheme-filter-regexp str))) - -(defun scheme-get-old-input () - "Snarf the sexp ending at point." - (save-excursion - (let ((end (point))) - (backward-sexp) - (buffer-substring (point) end)))) - -(defun scheme-args-to-list (string) - (let ((where (string-match "[ \t]" string))) - (cond ((null where) (list string)) - ((not (= where 0)) - (cons (substring string 0 where) - (scheme-args-to-list (substring string (+ 1 where) - (length string))))) - (t (let ((pos (string-match "[^ \t]" string))) - (if (null pos) - nil - (scheme-args-to-list (substring string pos - (length string))))))))) - -;;;###autoload -(defun run-scheme (cmd) - "Run an inferior Scheme process, input and output via buffer *scheme*. -If there is a process already running in `*scheme*', switch to that buffer. -With argument, allows you to edit the command line (default is value -of `scheme-program-name'). Runs the hooks `inferior-scheme-mode-hook' -\(after the `comint-mode-hook' is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - - (interactive (list (if current-prefix-arg - (read-string "Run Scheme: " scheme-program-name) - scheme-program-name))) - (if (not (comint-check-proc "*scheme*")) - (let ((cmdlist (scheme-args-to-list cmd))) - (set-buffer (apply 'make-comint "scheme" (car cmdlist) - nil (cdr cmdlist))) - (inferior-scheme-mode))) - (setq scheme-program-name cmd) - (setq scheme-buffer "*scheme*") - (pop-to-buffer "*scheme*")) -;;;###autoload (add-hook 'same-window-buffer-names "*scheme*") - -(defun scheme-send-region (start end) - "Send the current region to the inferior Scheme process." - (interactive "r") - (comint-send-region (scheme-proc) start end) - (comint-send-string (scheme-proc) "\n")) - -(defun scheme-send-definition () - "Send the current definition to the inferior Scheme process." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (scheme-send-region (point) end)))) - -(defun scheme-send-last-sexp () - "Send the previous sexp to the inferior Scheme process." - (interactive) - (scheme-send-region (save-excursion (backward-sexp) (point)) (point))) - -(defcustom scheme-compile-exp-command "(compile '%s)" - "*Template for issuing commands to compile arbitrary Scheme expressions." - :type 'string - :group 'cmuscheme) - -(defun scheme-compile-region (start end) - "Compile the current region in the inferior Scheme process. -\(A BEGIN is wrapped around the region: (BEGIN ))" - (interactive "r") - (comint-send-string (scheme-proc) (format scheme-compile-exp-command - (format "(begin %s)" - (buffer-substring start end)))) - (comint-send-string (scheme-proc) "\n")) - -(defun scheme-compile-definition () - "Compile the current definition in the inferior Scheme process." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (scheme-compile-region (point) end)))) - -(defun switch-to-scheme (eob-p) - "Switch to the scheme process buffer. -With argument, position cursor at end of buffer." - (interactive "P") - (if (get-buffer scheme-buffer) - (pop-to-buffer scheme-buffer) - (error "No current process buffer. See variable `scheme-buffer'")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - -(defun scheme-send-region-and-go (start end) - "Send the current region to the inferior Scheme process. -Then switch to the process buffer." - (interactive "r") - (scheme-send-region start end) - (switch-to-scheme t)) - -(defun scheme-send-definition-and-go () - "Send the current definition to the inferior Scheme. -Then switch to the process buffer." - (interactive) - (scheme-send-definition) - (switch-to-scheme t)) - -(defun scheme-compile-definition-and-go () - "Compile the current definition in the inferior Scheme. -Then switch to the process buffer." - (interactive) - (scheme-compile-definition) - (switch-to-scheme t)) - -(defun scheme-compile-region-and-go (start end) - "Compile the current region in the inferior Scheme. -Then switch to the process buffer." - (interactive "r") - (scheme-compile-region start end) - (switch-to-scheme t)) - -(defcustom scheme-source-modes '(scheme-mode) - "*Used to determine if a buffer contains Scheme source code. -If it's loaded into a buffer that is in one of these major modes, it's -considered a scheme source file by `scheme-load-file' and `scheme-compile-file'. -Used by these commands to determine defaults." - :type '(repeat function) - :group 'cmuscheme) - -(defvar scheme-prev-l/c-dir/file nil - "Caches the last (directory . file) pair. -Caches the last pair used in the last `scheme-load-file' or -`scheme-compile-file' command. Used for determining the default in the -next one.") - -(defun scheme-load-file (file-name) - "Load a Scheme file FILE-NAME into the inferior Scheme process." - (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file - scheme-source-modes t)) ; T because LOAD - ; needs an exact name - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (scheme-proc) (concat "(load \"" - file-name - "\"\)\n"))) - -(defun scheme-compile-file (file-name) - "Compile a Scheme file FILE-NAME in the inferior Scheme process." - (interactive (comint-get-source "Compile Scheme file: " - scheme-prev-l/c-dir/file - scheme-source-modes - nil)) ; NIL because COMPILE doesn't - ; need an exact name. - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (scheme-proc) (concat "(compile-file \"" - file-name - "\"\)\n"))) - - -(defvar scheme-buffer nil "*The current scheme process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme -processes. To run multiple Scheme processes, you start the first up with -\\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer -with \\[rename-buffer]. You may now start up a new process with another -\\[run-scheme]. It will be in a new buffer, named *scheme*. You can -switch between the different process buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Scheme processes -- -like `scheme-send-definition' or `scheme-compile-region' -- have to choose a -process to send to, when you have more than one Scheme process around. This -is determined by the global variable `scheme-buffer'. Suppose you -have three inferior Schemes running: - Buffer Process - foo scheme - bar scheme<2> - *scheme* scheme<3> -If you do a \\[scheme-send-definition-and-go] command on some Scheme source -code, what process do you send it to? - -- If you're in a process buffer (foo, bar, or *scheme*), - you send it to that process. -- If you're in some other buffer (e.g., a source file), you - send it to the process attached to buffer `scheme-buffer'. -This process selection is performed by function `scheme-proc'. - -Whenever \\[run-scheme] fires up a new process, it resets `scheme-buffer' -to be the new process's buffer. If you only run one process, this will -do the right thing. If you run multiple processes, you can change -`scheme-buffer' to another process buffer with \\[set-variable]. - -More sophisticated approaches are, of course, possible. If you find yourself -needing to switch back and forth between multiple processes frequently, -you may wish to consider ilisp.el, a larger, more sophisticated package -for running inferior Lisp and Scheme processes. The approach taken here is -for a minimal, simple implementation. Feel free to extend it.") - -(defun scheme-proc () - "Return the current scheme process. See variable `scheme-buffer'." - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode) - (current-buffer) - scheme-buffer)))) - (or proc - (error "No current process. See variable `scheme-buffer'")))) - - -;;; Do the user's customisation... - -(defcustom cmuscheme-load-hook nil - "This hook is run when cmuscheme is loaded in. -This is a good place to put keybindings." - :type 'hook - :group 'cmuscheme) - -(run-hooks 'cmuscheme-load-hook) - -(provide 'cmuscheme) - -;;; cmuscheme.el ends here rmfile ./site-lisp/guileint-1.5/cmuscheme.el hunk ./site-lisp/guileint-1.5/comint.el 1 -;;; comint.el --- general command interpreter in a window stuff - -;; Copyright (C) 1988, 90, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 -;; Free Software Foundation, Inc. - -;; Author: Olin Shivers -;; Simon Marshall -;; Maintainer: FSF -;; Keywords: processes - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Please send me bug reports, bug fixes, and extensions, so that I can -;; merge them into the master source. -;; - Olin Shivers (shivers@cs.cmu.edu) -;; - Simon Marshall (simon@gnu.org) - -;; This file defines a general command-interpreter-in-a-buffer package -;; (comint mode). The idea is that you can build specific process-in-a-buffer -;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... -;; This way, all these specific packages share a common base functionality, -;; and a common set of bindings, which makes them easier to use (and -;; saves code, implementation time, etc., etc.). - -;; Several packages are already defined using comint mode: -;; - shell.el defines a shell-in-a-buffer mode. -;; - cmulisp.el defines a simple lisp-in-a-buffer mode. -;; -;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. -;; - The file tea.el tunes scheme and inferior-scheme modes for T. -;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. -;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, -;; previewers, and printers from within emacs. -;; - background.el allows csh-like job control inside emacs. -;; It is pretty easy to make new derived modes for other processes. - -;; For documentation on the functionality provided by comint mode, and -;; the hooks available for customising it, see the comments below. -;; For further information on the standard derived modes (shell, -;; inferior-lisp, inferior-scheme, ...), see the relevant source files. - -;; For hints on converting existing process modes (e.g., tex-mode, -;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode -;; instead of shell-mode, see the notes at the end of this file. - - -;; Brief Command Documentation: -;;============================================================================ -;; Comint Mode Commands: (common to all derived modes, like shell & cmulisp -;; mode) -;; -;; m-p comint-previous-input Cycle backwards in input history -;; m-n comint-next-input Cycle forwards -;; m-r comint-previous-matching-input Previous input matching a regexp -;; m-s comint-next-matching-input Next input that matches -;; m-c-l comint-show-output Show last batch of process output -;; return comint-send-input -;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff -;; c-c c-a comint-bol-or-process-mark First time, move point to bol; -;; second time, move to process-mark. -;; c-c c-u comint-kill-input ^u -;; c-c c-w backward-kill-word ^w -;; c-c c-c comint-interrupt-subjob ^c -;; c-c c-z comint-stop-subjob ^z -;; c-c c-\ comint-quit-subjob ^\ -;; c-c c-o comint-delete-output Delete last batch of process output -;; c-c c-r comint-show-output Show last batch of process output -;; c-c c-l comint-dynamic-list-input-ring List input history -;; -;; Not bound by default in comint-mode (some are in shell mode) -;; comint-run Run a program under comint-mode -;; send-invisible Read a line w/o echo, and send to proc -;; comint-dynamic-complete-filename Complete filename at point. -;; comint-dynamic-list-filename-completions List completions in help buffer. -;; comint-replace-by-expanded-filename Expand and complete filename at point; -;; replace with expanded/completed name. -;; comint-replace-by-expanded-history Expand history at point; -;; replace with expanded name. -;; comint-magic-space Expand history and add (a) space(s). -;; comint-kill-subjob No mercy. -;; comint-show-maximum-output Show as much output as possible. -;; comint-continue-subjob Send CONT signal to buffer's process -;; group. Useful if you accidentally -;; suspend your process (with C-c C-z). -;; comint-get-next-from-history Fetch successive input history lines -;; comint-accumulate Combine lines to send them together -;; as input. -;; comint-goto-process-mark Move point to where process-mark is. -;; comint-set-process-mark Set process-mark to point. - -;; comint-mode-hook is the comint mode hook. Basically for your keybindings. - -;;; Code: - -(require 'ring) - -;; Buffer Local Variables: -;;============================================================================ -;; Comint mode buffer local variables: -;; comint-prompt-regexp string comint-bol uses to match prompt -;; comint-delimiter-argument-list list For delimiters and arguments -;; comint-last-input-start marker Handy if inferior always echoes -;; comint-last-input-end marker For comint-delete-output command -;; comint-input-ring-size integer For the input history -;; comint-input-ring ring mechanism -;; comint-input-ring-index number ... -;; comint-save-input-ring-index number ... -;; comint-input-autoexpand symbol ... -;; comint-input-ignoredups boolean ... -;; comint-dynamic-complete-functions hook For the completion mechanism -;; comint-completion-fignore list ... -;; comint-file-name-chars string ... -;; comint-file-name-quote-list list ... -;; comint-get-old-input function Hooks for specific -;; comint-input-filter-functions hook process-in-a-buffer -;; comint-output-filter-functions hook function modes. -;; comint-unallowed-output-filter-functions hook -;; comint-preoutput-filter-functions hook -;; comint-input-filter function ... -;; comint-output-filter-function function ... -;; comint-input-sender function ... -;; comint-eol-on-send boolean ... -;; comint-process-echoes boolean ... -;; comint-scroll-to-bottom-on-input symbol For scroll behavior -;; comint-scroll-to-bottom-on-output symbol ... -;; comint-scroll-show-maximum-output boolean ... -;; comint-accum-marker maker For comint-accumulate -;; comint-last-output-overlay overlay -;; -;; Comint mode non-buffer local variables: -;; comint-completion-addsuffix boolean/cons For file name -;; comint-completion-autolist boolean completion behavior -;; comint-completion-recexact boolean ... - -(defgroup comint nil - "General command interpreter in a window stuff." - :group 'processes) - -(defgroup comint-completion nil - "Completion facilities in comint" - :group 'comint) - -(defgroup comint-source nil - "Source finding facilities in comint" - :prefix "comint-" - :group 'comint) - -(defvar comint-prompt-regexp "^" - "Regexp to recognise prompts in the inferior process. -Defaults to \"^\", the null string at BOL. - -This variable is only used if the variable -`comint-use-prompt-regexp-instead-of-fields' is non-nil. - -Good choices: - Canonical Lisp: \"^[^> \\n]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) - Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" - franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" - kcl: \"^>+ *\" - shell: \"^[^#$%>\\n]*[#$%>] *\" - T: \"^>+ *\" - -This is a good thing to set in mode hooks.") - -(defvar comint-delimiter-argument-list () - "List of characters to recognise as separate arguments in input. -Strings comprising a character in this list will separate the arguments -surrounding them, and also be regarded as arguments in their own right (unlike -whitespace). See `comint-arguments'. -Defaults to the empty list. - -For shells, a good value is (?\\| ?& ?< ?> ?\\( ?\\) ?;). - -This is a good thing to set in mode hooks.") - -(defcustom comint-input-autoexpand nil - "*If non-nil, expand input command history references on completion. -This mirrors the optional behavior of tcsh (its autoexpand and histlit). - -If the value is `input', then the expansion is seen on input. -If the value is `history', then the expansion is only when inserting -into the buffer's input ring. See also `comint-magic-space' and -`comint-dynamic-complete'. - -This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const input) - (const history) - (other :tag "on" t)) - :group 'comint) - -(defcustom comint-highlight-input t - "*If non-nil, highlight input; also allow choosing previous input with a mouse. -The face used is `comint-highlight-input'." - :type 'boolean - :group 'comint) - -(defface comint-highlight-input '((t (:bold t))) - "Face to use to highlight input when `comint-highlight-input' is non-nil." - :group 'comint) - -(defcustom comint-highlight-prompt t - "*If non-nil, highlight program prompts. -The face used is `comint-highlight-prompt'." - :type 'boolean - :group 'comint) - -(defface comint-highlight-prompt - '((((background dark)) (:foreground "cyan")) - (t (:foreground "dark blue"))) - "Face to use to highlight prompt when `comint-highlight-prompt' is non-nil." - :group 'comint) - -(defcustom comint-input-ignoredups nil - "*If non-nil, don't add input matching the last on the input ring. -This mirrors the optional behavior of bash. - -This variable is buffer-local." - :type 'boolean - :group 'comint) - -(defcustom comint-input-ring-file-name nil - "*If non-nil, name of the file to read/write input history. -See also `comint-read-input-ring' and `comint-write-input-ring'. - -This variable is buffer-local, and is a good thing to set in mode hooks." - :type '(choice (const :tag "nil" nil) - file) - :group 'comint) - -(defcustom comint-scroll-to-bottom-on-input nil - "*Controls whether input to interpreter causes window to scroll. -If nil, then do not scroll. If t or `all', scroll all windows showing buffer. -If `this', scroll only the selected window. - -The default is nil. - -See `comint-preinput-scroll-to-bottom'. This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const t) - (const all) - (const this)) - :group 'comint) - -(defcustom comint-scroll-to-bottom-on-output nil - "*Controls whether interpreter output causes window to scroll. -If nil, then do not scroll. If t or `all', scroll all windows showing buffer. -If `this', scroll only the selected window. -If `others', scroll only those that are not the selected window. - -The default is nil. - -See variable `comint-scroll-show-maximum-output' and function -`comint-postoutput-scroll-to-bottom'. This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const t) - (const all) - (const this) - (const others)) - :group 'comint) - -(defcustom comint-scroll-show-maximum-output nil - "*Controls how interpreter output causes window to scroll. -If non-nil, then show the maximum output when the window is scrolled. - -See variable `comint-scroll-to-bottom-on-output' and function -`comint-postoutput-scroll-to-bottom'. This variable is buffer-local." - :type 'boolean - :group 'comint) - -(defcustom comint-buffer-maximum-size 1024 - "*The maximum size in lines for comint buffers. -Comint buffers are truncated from the top to be no greater than this number, if -the function `comint-truncate-buffer' is on `comint-output-filter-functions'." - :type 'integer - :group 'comint) - -(defvar comint-input-ring-size 32 - "Size of input history ring.") - -(defvar comint-input-ring-separator "\n" - "Separator between commands in the history file.") - -(defvar comint-input-history-ignore "^#" - "Regexp for history entries that should be ignored when comint initializes.") - -(defcustom comint-process-echoes nil - "*If non-nil, assume that the subprocess echoes any input. -If so, delete one copy of the input so that only one copy eventually -appears in the buffer. - -This variable is buffer-local." - :type 'boolean - :group 'comint) - -;; AIX puts the name of the person being su'd to in front of the prompt. -;; kinit prints a prompt like `Password for devnull@GNU.ORG: '. -;; ksu prints a prompt like `Kerberos password for devnull/root@GNU.ORG: '. -;; ssh-add prints a prompt like `Enter passphrase: '. -;; Some implementations of passwd use "Password (again)" as the 2nd prompt. -(defcustom comint-password-prompt-regexp - "\\(\\([Oo]ld \\|[Nn]ew \\|Kerberos \\|'s \\|login \\|CVS \\|^\\)\ -[Pp]assword\\( (again)\\)?\\|pass phrase\\|Enter passphrase\\)\ -\\( for [^@ \t\n]+@[^@ \t\n]+\\)?:\\s *\\'" - "*Regexp matching prompts for passwords in the inferior process. -This is used by `comint-watch-for-password-prompt'." - :type 'regexp - :group 'comint) - -;; Here are the per-interpreter hooks. -(defvar comint-get-old-input (function comint-get-old-input-default) - "Function that returns old text in comint mode. -This function is called when return is typed while the point is in old -text. It returns the text to be submitted as process input. The -default is `comint-get-old-input-default', which either grabs the -current input field or grabs the current line and strips off leading -text matching `comint-prompt-regexp', depending on the value of -`comint-use-prompt-regexp-instead-of-fields'.") - -(defvar comint-dynamic-complete-functions - '(comint-replace-by-expanded-history comint-dynamic-complete-filename) - "List of functions called to perform completion. -Functions should return non-nil if completion was performed. -See also `comint-dynamic-complete'. - -This is a good thing to set in mode hooks.") - -(defvar comint-input-filter - (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) - "Predicate for filtering additions to input history. -Takes one argument, the input. If non-nil, the input may be saved on the input -history list. Default is to save anything that isn't all whitespace.") - -(defvar comint-input-filter-functions '() - "Functions to call before input is sent to the process. -These functions get one argument, a string containing the text to send. - -This variable is buffer-local.") - -(defvar comint-output-filter-function 'comint-output-filter - "Selects which process output filter to use. -It's normal value is `comint-output-filter' but if you want your process -to control emacs via a one-character protocol as in xscheme, set it to -`comint-dispatch-output-filter' and describe your protocol using the -variables `comint-dispatch-escape-character' and -`comint-dispatch-alist'. - -This variable is buffer-local.") - -(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom) - "Functions to call after output is inserted into the buffer. -One possible function is `comint-postoutput-scroll-to-bottom'. -These functions get one argument, a string containing the text as originally -inserted. Note that this might not be the same as the buffer contents between -`comint-last-output-start' and the buffer's `process-mark', if other filter -functions have already modified the buffer. - -See also `comint-preoutput-filter-functions'. - -This variable is buffer-local.") - -(defvar comint-allow-output-p t - "Setting this varible to nil inhibits process output.") - -(defvar comint-unallowed-output-filter-functions '() - "Functions to call with output which the process generates while -`comint-allow-output-p' is nil.") - -(defvar comint-dispatch-state 'idle - "State of scheme process escape reader state machine: -idle waiting for an escape sequence -reading-type received an escape character but nothing else -reading-string reading string") - -(defvar comint-string-accumulator "" - "Accumulator for the string being received from the process.") - -(defvar comint-string-receiver nil - "Procedure to send the string argument from the process.") - -(defvar comint-receiving-buffer nil) - -(defvar comint-buffer-receiver nil) - -(defvar comint-input-sender (function comint-simple-send) - "Function to actually send to PROCESS the STRING submitted by user. -Usually this is just `comint-simple-send', but if your mode needs to -massage the input string, put a different function here. -`comint-simple-send' just sends the string plus a newline. -This is called from the user command `comint-send-input'.") - -(defcustom comint-eol-on-send t - "*Non-nil means go to the end of the line before sending input. -See `comint-send-input'." - :type 'boolean - :group 'comint) - -;; Note: If it is decided to purge comint-prompt-regexp from the source -;; entirely, searching for uses of this variable will help to identify -;; places that need attention. -(defcustom comint-use-prompt-regexp-instead-of-fields nil - "*If non-nil, use `comint-prompt-regexp' to distinguish prompts from user-input. -If nil, then program output and user-input are given different `field' -properties, which emacs commands can use to distinguish them (in -particular, common movement commands such as begining-of-line respect -field boundaries in a natural way)." - :type 'boolean - :group 'comint) - -(defcustom comint-mode-hook '() - "Called upon entry into `comint-mode' -This is run before the process is cranked up." - :type 'hook - :group 'comint) - -(defcustom comint-exec-hook '() - "Called each time a process is exec'd by `comint-exec'. -This is called after the process is cranked up. It is useful for things that -must be done each time a process is executed in a comint mode buffer (e.g., -`(process-kill-without-query)'). In contrast, the `comint-mode-hook' is only -executed once when the buffer is created." - :type 'hook - :group 'comint) - -(defvar comint-mode-map nil) - -(defvar comint-ptyp t - "Non-nil if communications via pty; false if by pipe. Buffer local. -This is to work around a bug in Emacs process signaling.") - -(defvar comint-input-ring nil) -(defvar comint-last-input-start) -(defvar comint-last-input-end) -(defvar comint-last-output-start) -(defvar comint-input-ring-index nil - "Index of last matched history element.") -(defvar comint-matching-input-from-input-string "" - "Input previously used to match input history.") -(defvar comint-save-input-ring-index - "Last input ring index which you copied. -This is to support the command \\[comint-get-next-from-history].") - -(defvar comint-accum-marker nil - "Non-nil if you are accumulating input lines to send as input together. -The command \\[comint-accumulate] sets this.") - -(put 'comint-replace-by-expanded-history 'menu-enable 'comint-input-autoexpand) -(put 'comint-input-ring 'permanent-local t) -(put 'comint-input-ring-index 'permanent-local t) -(put 'comint-save-input-ring-index 'permanent-local t) -(put 'comint-input-autoexpand 'permanent-local t) -(put 'comint-input-filter-functions 'permanent-local t) -(put 'comint-output-filter-function 'permanent-local t) -(put 'comint-output-filter-functions 'permanent-local t) -(put 'comint-unallowed-output-filter-functions 'permanent-local t) -(put 'comint-preoutput-filter-functions 'permanent-local t) -(put 'comint-scroll-to-bottom-on-input 'permanent-local t) -(put 'comint-scroll-to-bottom-on-output 'permanent-local t) -(put 'comint-scroll-show-maximum-output 'permanent-local t) -(put 'comint-ptyp 'permanent-local t) - -(put 'comint-mode 'mode-class 'special) - -(define-derived-mode comint-mode fundamental-mode "Comint" - "Major mode for interacting with an inferior interpreter. -Interpreter name is same as buffer name, sans the asterisks. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -Setting variable `comint-eol-on-send' means jump to the end of the line -before submitting new input. - -This mode is customised to create major modes such as Inferior Lisp -mode, Shell mode, etc. This can be done by setting the hooks -`comint-input-filter-functions', `comint-input-filter', `comint-input-sender' -and `comint-get-old-input' to appropriate functions, and the variable -`comint-prompt-regexp' to the appropriate regular expression. - -An input history is maintained of size `comint-input-ring-size', and -can be accessed with the commands \\[comint-next-input], \\[comint-previous-input], and \\[comint-dynamic-list-input-ring]. -Input ring history expansion can be achieved with the commands -\\[comint-replace-by-expanded-history] or \\[comint-magic-space]. -Input ring expansion is controlled by the variable `comint-input-autoexpand', -and addition is controlled by the variable `comint-input-ignoredups'. - -Commands with no default key bindings include `send-invisible', -`comint-dynamic-complete', `comint-dynamic-list-filename-completions', and -`comint-magic-space'. - -Input to, and output from, the subprocess can cause the window to scroll to -the end of the buffer. See variables `comint-output-filter-functions', -`comint-preoutput-filter-functions', `comint-scroll-to-bottom-on-input', -and `comint-scroll-to-bottom-on-output'. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -\\{comint-mode-map} - -Entry to this mode runs the hooks on `comint-mode-hook'." - (setq mode-line-process '(":%s")) - (make-local-variable 'comint-last-input-start) - (setq comint-last-input-start (make-marker)) - (set-marker comint-last-input-start (point-min)) - (make-local-variable 'comint-last-input-end) - (setq comint-last-input-end (make-marker)) - (set-marker comint-last-input-end (point-min)) - (make-local-variable 'comint-last-output-start) - (setq comint-last-output-start (make-marker)) - (make-local-variable 'comint-last-output-overlay) - (make-local-variable 'comint-last-prompt-overlay) - (make-local-variable 'comint-prompt-regexp) ; Don't set; default - (make-local-variable 'comint-input-ring-size) ; ...to global val. - (make-local-variable 'comint-input-ring) - (make-local-variable 'comint-input-ring-file-name) - (or (and (boundp 'comint-input-ring) comint-input-ring) - (setq comint-input-ring (make-ring comint-input-ring-size))) - (make-local-variable 'comint-input-ring-index) - (make-local-variable 'comint-save-input-ring-index) - (or (and (boundp 'comint-input-ring-index) comint-input-ring-index) - (setq comint-input-ring-index nil)) - (or (and (boundp 'comint-save-input-ring-index) comint-save-input-ring-index) - (setq comint-save-input-ring-index nil)) - (make-local-variable 'comint-matching-input-from-input-string) - (make-local-variable 'comint-input-autoexpand) - (make-local-variable 'comint-input-ignoredups) - (make-local-variable 'comint-delimiter-argument-list) - (make-local-hook 'comint-dynamic-complete-functions) - (make-local-variable 'comint-completion-fignore) - (make-local-variable 'comint-get-old-input) - (make-local-hook 'comint-input-filter-functions) - (make-local-variable 'comint-input-filter) - (make-local-variable 'comint-input-sender) - (make-local-variable 'comint-eol-on-send) - (make-local-variable 'comint-scroll-to-bottom-on-input) - (make-local-variable 'comint-scroll-to-bottom-on-output) - (make-local-variable 'comint-scroll-show-maximum-output) - (add-hook 'pre-command-hook 'comint-preinput-scroll-to-bottom t t) - (make-local-variable 'comint-output-filter-function) - (make-local-variable 'comint-allow-output-p) - (make-local-variable 'comint-dispatch-state) - (make-local-variable 'comint-string-accumulator) - (make-local-variable 'comint-string-receiver) - (make-local-variable 'comint-receiving-buffer) - (make-local-variable 'comint-buffer-receiver) - (make-local-hook 'comint-output-filter-functions) - (make-local-hook 'comint-unallowed-output-filter-functions) - (make-local-hook 'comint-exec-hook) - (make-local-variable 'comint-ptyp) - (make-local-variable 'comint-process-echoes) - (make-local-variable 'comint-file-name-chars) - (make-local-variable 'comint-file-name-quote-list) - (make-local-variable 'comint-accum-marker) - (setq comint-accum-marker (make-marker)) - (set-marker comint-accum-marker nil) - ;; This behavior is not useful in comint buffers, and is annoying - (set (make-local-variable 'next-line-add-newlines) nil)) - -(if comint-mode-map - nil - ;; Keys: - (setq comint-mode-map (make-sparse-keymap)) - (define-key comint-mode-map "\ep" 'comint-previous-input) - (define-key comint-mode-map "\en" 'comint-next-input) - (define-key comint-mode-map [C-up] 'comint-previous-input) - (define-key comint-mode-map [C-down] 'comint-next-input) - (define-key comint-mode-map "\er" 'comint-previous-matching-input) - (define-key comint-mode-map "\es" 'comint-next-matching-input) - (define-key comint-mode-map [?\C-c ?\M-r] 'comint-previous-matching-input-from-input) - (define-key comint-mode-map [?\C-c ?\M-s] 'comint-next-matching-input-from-input) - (define-key comint-mode-map "\e\C-l" 'comint-show-output) - (define-key comint-mode-map "\C-m" 'comint-send-input) - (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) - (define-key comint-mode-map "\C-c " 'comint-accumulate) - (define-key comint-mode-map "\C-c\C-x" 'comint-get-next-from-history) - (define-key comint-mode-map "\C-c\C-a" 'comint-bol-or-process-mark) - (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) - (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) - (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) - (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) - (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) - (define-key comint-mode-map "\C-c\C-m" 'comint-copy-old-input) - (define-key comint-mode-map "\C-c\C-o" 'comint-delete-output) - (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) - (define-key comint-mode-map "\C-c\C-e" 'comint-show-maximum-output) - (define-key comint-mode-map "\C-c\C-l" 'comint-dynamic-list-input-ring) - (define-key comint-mode-map "\C-c\C-n" 'comint-next-prompt) - (define-key comint-mode-map "\C-c\C-p" 'comint-previous-prompt) - (define-key comint-mode-map "\C-c\C-d" 'comint-send-eof) - (define-key comint-mode-map "\C-c\C-s" 'comint-write-output) - ;; Mouse Buttons: - (define-key comint-mode-map [mouse-2] 'comint-insert-clicked-input) - ;; Menu bars: - ;; completion: - (define-key comint-mode-map [menu-bar completion] - (cons "Complete" (make-sparse-keymap "Complete"))) - (define-key comint-mode-map [menu-bar completion complete-expand] - '("Expand File Name" . comint-replace-by-expanded-filename)) - (define-key comint-mode-map [menu-bar completion complete-listing] - '("File Completion Listing" . comint-dynamic-list-filename-completions)) - (define-key comint-mode-map [menu-bar completion complete-file] - '("Complete File Name" . comint-dynamic-complete-filename)) - (define-key comint-mode-map [menu-bar completion complete] - '("Complete Before Point" . comint-dynamic-complete)) - ;; Input history: - (define-key comint-mode-map [menu-bar inout] - (cons "In/Out" (make-sparse-keymap "In/Out"))) - (define-key comint-mode-map [menu-bar inout delete-output] - '("Delete Current Output Group" . comint-delete-output)) - (define-key comint-mode-map [menu-bar inout append-output-to-file] - '("Append Current Output Group to File" . comint-append-output-to-file)) - (define-key comint-mode-map [menu-bar inout write-output] - '("Write Current Output Group to File" . comint-write-output)) - (define-key comint-mode-map [menu-bar inout next-prompt] - '("Forward Output Group" . comint-next-prompt)) - (define-key comint-mode-map [menu-bar inout previous-prompt] - '("Backward Output Group" . comint-previous-prompt)) - (define-key comint-mode-map [menu-bar inout show-maximum-output] - '("Show Maximum Output" . comint-show-maximum-output)) - (define-key comint-mode-map [menu-bar inout show-output] - '("Show Current Output Group" . comint-show-output)) - (define-key comint-mode-map [menu-bar inout kill-input] - '("Kill Current Input" . comint-kill-input)) - (define-key comint-mode-map [menu-bar inout copy-input] - '("Copy Old Input" . comint-copy-old-input)) - (define-key comint-mode-map [menu-bar inout forward-matching-history] - '("Forward Matching Input..." . comint-forward-matching-input)) - (define-key comint-mode-map [menu-bar inout backward-matching-history] - '("Backward Matching Input..." . comint-backward-matching-input)) - (define-key comint-mode-map [menu-bar inout next-matching-history] - '("Next Matching Input..." . comint-next-matching-input)) - (define-key comint-mode-map [menu-bar inout previous-matching-history] - '("Previous Matching Input..." . comint-previous-matching-input)) - (define-key comint-mode-map [menu-bar inout next-matching-history-from-input] - '("Next Matching Current Input" . comint-next-matching-input-from-input)) - (define-key comint-mode-map [menu-bar inout previous-matching-history-from-input] - '("Previous Matching Current Input" . comint-previous-matching-input-from-input)) - (define-key comint-mode-map [menu-bar inout next-history] - '("Next Input" . comint-next-input)) - (define-key comint-mode-map [menu-bar inout previous-history] - '("Previous Input" . comint-previous-input)) - (define-key comint-mode-map [menu-bar inout list-history] - '("List Input History" . comint-dynamic-list-input-ring)) - (define-key comint-mode-map [menu-bar inout expand-history] - '("Expand History Before Point" . comint-replace-by-expanded-history)) - ;; Signals - (define-key comint-mode-map [menu-bar signals] - (cons "Signals" (make-sparse-keymap "Signals"))) - (define-key comint-mode-map [menu-bar signals eof] - '("EOF" . comint-send-eof)) - (define-key comint-mode-map [menu-bar signals kill] - '("KILL" . comint-kill-subjob)) - (define-key comint-mode-map [menu-bar signals quit] - '("QUIT" . comint-quit-subjob)) - (define-key comint-mode-map [menu-bar signals cont] - '("CONT" . comint-continue-subjob)) - (define-key comint-mode-map [menu-bar signals stop] - '("STOP" . comint-stop-subjob)) - (define-key comint-mode-map [menu-bar signals break] - '("BREAK" . comint-interrupt-subjob)) - ;; Put them in the menu bar: - (setq menu-bar-final-items (append '(completion inout signals) - menu-bar-final-items)) - ) - -(defun comint-check-proc (buffer) - "Return t if there is a living process associated w/buffer BUFFER. -Living means the status is `open', `run', or `stop'. -BUFFER can be either a buffer or the name of one." - (let ((proc (get-buffer-process buffer))) - (and proc (memq (process-status proc) '(open run stop))))) - -;;;###autoload -(defun make-comint-in-buffer (name buffer program &optional startfile &rest switches) - "Make a comint process NAME in BUFFER, running PROGRAM. -If BUFFER is nil, it defaults to NAME surrounded by `*'s. -PROGRAM should be either a string denoting an executable program to create -via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP -connection to be opened via `open-network-stream'. If there is already a -running process in that buffer, it is not restarted. Optional third arg -STARTFILE is the name of a file to send the contents of to the process. - -If PROGRAM is a string, any more args are arguments to PROGRAM." - (or (fboundp 'start-process) - (error "Multi-processing is not supported for this system")) - (setq buffer (get-buffer-create (or buffer (concat "*" name "*")))) - ;; If no process, or nuked process, crank up a new one and put buffer in - ;; comint mode. Otherwise, leave buffer and existing process alone. - (unless (comint-check-proc buffer) - (with-current-buffer buffer - (comint-mode)) ; Install local vars, mode, keymap, ... - (comint-exec buffer name program startfile switches)) - buffer) - -;;;###autoload -(defun make-comint (name program &optional startfile &rest switches) - "Make a comint process NAME in a buffer, running PROGRAM. -The name of the buffer is made by surrounding NAME with `*'s. -PROGRAM should be either a string denoting an executable program to create -via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP -connection to be opened via `open-network-stream'. If there is already a -running process in that buffer, it is not restarted. Optional third arg -STARTFILE is the name of a file to send the contents of to the process. - -If PROGRAM is a string, any more args are arguments to PROGRAM." - (apply #'make-comint-in-buffer name nil program startfile switches)) - -;;;###autoload -(defun comint-run (program) - "Run PROGRAM in a comint buffer and switch to it. -The buffer name is made by surrounding the file name of PROGRAM with `*'s. -The file name is used to make a symbol name, such as `comint-sh-hook', and any -hooks on this symbol are run in the buffer. -See `make-comint' and `comint-exec'." - (interactive "sRun program: ") - (let ((name (file-name-nondirectory program))) - (switch-to-buffer (make-comint name program)) - (run-hooks (intern-soft (concat "comint-" name "-hook"))))) - -(defun comint-exec (buffer name command startfile switches) - "Start up a process in buffer BUFFER for comint modes. -Blasts any old process running in the buffer. Doesn't set the buffer mode. -You can use this to cheaply run a series of processes in the same comint -buffer. The hook `comint-exec-hook' is run after each exec." - (save-excursion - (set-buffer buffer) - (let ((proc (get-buffer-process buffer))) ; Blast any old process. - (if proc (delete-process proc))) - ;; Crank up a new process - (let ((proc - (if (consp command) - (open-network-stream name buffer (car command) (cdr command)) - (comint-exec-1 name buffer command switches)))) - (set-process-filter proc comint-output-filter-function) - (let ((init-fn (get 'comint-output-filter-function 'initialize))) - (and init-fn (funcall init-fn))) - (make-local-variable 'comint-ptyp) - (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. - ;; Jump to the end, and set the process mark. - (goto-char (point-max)) - (set-marker (process-mark proc) (point)) - ;; Feed it the startfile. - (cond (startfile - ;;This is guaranteed to wait long enough - ;;but has bad results if the comint does not prompt at all - ;; (while (= size (buffer-size)) - ;; (sleep-for 1)) - ;;I hope 1 second is enough! - (sleep-for 1) - (goto-char (point-max)) - (insert-file-contents startfile) - (setq startfile (buffer-substring (point) (point-max))) - (delete-region (point) (point-max)) - (comint-send-string proc startfile))) - (run-hooks 'comint-exec-hook) - buffer))) - -;; This auxiliary function cranks up the process for comint-exec in -;; the appropriate environment. - -(defun comint-exec-1 (name buffer command switches) - (let ((process-environment - (nconc - ;; If using termcap, we specify `emacs' as the terminal type - ;; because that lets us specify a width. - ;; If using terminfo, we specify `dumb' because that is - ;; a defined terminal type. `emacs' is not a defined terminal type - ;; and there is no way for us to define it here. - ;; Some programs that use terminfo get very confused - ;; if TERM is not a valid terminal type. - (if (and (boundp 'system-uses-terminfo) system-uses-terminfo) - (list "TERM=dumb" "TERMCAP=" - (format "COLUMNS=%d" (window-width))) - (list "TERM=emacs" - (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width)))) - (if (getenv "EMACS") nil (list "EMACS=t")) - process-environment)) - (default-directory - (if (file-accessible-directory-p default-directory) - default-directory - (char-to-string directory-sep-char))) - proc decoding encoding changed) - (let ((exec-path (if (file-name-directory command) - ;; If the command has slashes, make sure we - ;; first look relative to the current directory. - (cons default-directory exec-path) exec-path))) - (setq proc (apply 'start-process name buffer command switches))) - (let ((coding-systems (process-coding-system proc))) - (setq decoding (car coding-systems) - encoding (cdr coding-systems))) - ;; If start-process decided to use some coding system for decoding - ;; data sent from the process and the coding system doesn't - ;; specify EOL conversion, we had better convert CRLF to LF. - (if (vectorp (coding-system-eol-type decoding)) - (setq decoding (coding-system-change-eol-conversion decoding 'dos) - changed t)) - ;; Even if start-process left the coding system for encoding data - ;; sent from the process undecided, we had better use the same one - ;; as what we use for decoding. But, we should suppress EOL - ;; conversion. - (if (and decoding (not encoding)) - (setq encoding (coding-system-change-eol-conversion decoding 'unix) - changed t)) - (if changed - (set-process-coding-system proc decoding encoding)) - proc)) - - -(defun comint-insert-clicked-input (event) - "In a comint buffer, set the current input to the clicked-on previous input." - (interactive "e") - (let ((over (catch 'found - ;; Ignore non-input overlays - (dolist (ov (overlays-at (posn-point (event-end event)))) - (when (eq (overlay-get ov 'field) 'input) - (throw 'found ov)))))) - ;; Do we have input in this area? - (if over - (let ((input-str (buffer-substring (overlay-start over) - (overlay-end over)))) - (goto-char (point-max)) - (delete-region - ;; Can't use kill-region as it sets this-command - (or (marker-position comint-accum-marker) - (process-mark (get-buffer-process (current-buffer)))) - (point)) - (insert input-str)) - ;; Fall back to the global definition. - (let* ((keys (this-command-keys)) - (last-key (and (vectorp keys) (aref keys (1- (length keys))))) - (fun (and last-key (lookup-key global-map (vector last-key))))) - (if fun (call-interactively fun)))))) - - -;; Input history processing in a buffer -;; =========================================================================== -;; Useful input history functions, courtesy of the Ergo group. - -;; Eleven commands: -;; comint-dynamic-list-input-ring List history in help buffer. -;; comint-previous-input Previous input... -;; comint-previous-matching-input ...matching a string. -;; comint-previous-matching-input-from-input ... matching the current input. -;; comint-next-input Next input... -;; comint-next-matching-input ...matching a string. -;; comint-next-matching-input-from-input ... matching the current input. -;; comint-backward-matching-input Backwards input... -;; comint-forward-matching-input ...matching a string. -;; comint-replace-by-expanded-history Expand history at point; -;; replace with expanded history. -;; comint-magic-space Expand history and insert space. -;; -;; Three functions: -;; comint-read-input-ring Read into comint-input-ring... -;; comint-write-input-ring Write to comint-input-ring-file-name. -;; comint-replace-by-expanded-history-before-point Workhorse function. - -(defun comint-read-input-ring (&optional silent) - "Sets the buffer's `comint-input-ring' from a history file. -The name of the file is given by the variable `comint-input-ring-file-name'. -The history ring is of size `comint-input-ring-size', regardless of file size. -If `comint-input-ring-file-name' is nil this function does nothing. - -If the optional argument SILENT is non-nil, we say nothing about a -failure to read the history file. - -This function is useful for major mode commands and mode hooks. - -The commands stored in the history file are separated by the -`comint-input-ring-separator', and entries that match -`comint-input-history-ignore' are ignored. The most recent command -comes last. - -See also `comint-input-ignoredups' and `comint-write-input-ring'." - (cond ((or (null comint-input-ring-file-name) - (equal comint-input-ring-file-name "")) - nil) - ((not (file-readable-p comint-input-ring-file-name)) - (or silent - (message "Cannot read history file %s" - comint-input-ring-file-name))) - (t - (let* ((history-buf (get-buffer-create " *temp*")) - (file comint-input-ring-file-name) - (count 0) - (size comint-input-ring-size) - (ring (make-ring size))) - (unwind-protect - (save-excursion - (set-buffer history-buf) - (widen) - (erase-buffer) - (insert-file-contents file) - ;; Save restriction in case file is already visited... - ;; Watch for those date stamps in history files! - (goto-char (point-max)) - (let (start end history) - (while (and (< count comint-input-ring-size) - (re-search-backward comint-input-ring-separator nil t) - (setq end (match-beginning 0))) - (if (re-search-backward comint-input-ring-separator nil t) - (setq start (match-end 0)) - (setq start (point-min))) - (setq history (buffer-substring start end)) - (goto-char start) - (if (and (not (string-match comint-input-history-ignore history)) - (or (null comint-input-ignoredups) - (ring-empty-p ring) - (not (string-equal (ring-ref ring 0) history)))) - (progn - (ring-insert-at-beginning ring history) - (setq count (1+ count))))))) - (kill-buffer history-buf)) - (setq comint-input-ring ring - comint-input-ring-index nil))))) - -(defun comint-write-input-ring () - "Writes the buffer's `comint-input-ring' to a history file. -The name of the file is given by the variable `comint-input-ring-file-name'. -The original contents of the file are lost if `comint-input-ring' is not empty. -If `comint-input-ring-file-name' is nil this function does nothing. - -Useful within process sentinels. - -See also `comint-read-input-ring'." - (cond ((or (null comint-input-ring-file-name) - (equal comint-input-ring-file-name "") - (null comint-input-ring) (ring-empty-p comint-input-ring)) - nil) - ((not (file-writable-p comint-input-ring-file-name)) - (message "Cannot write history file %s" comint-input-ring-file-name)) - (t - (let* ((history-buf (get-buffer-create " *Temp Input History*")) - (ring comint-input-ring) - (file comint-input-ring-file-name) - (index (ring-length ring))) - ;; Write it all out into a buffer first. Much faster, but messier, - ;; than writing it one line at a time. - (save-excursion - (set-buffer history-buf) - (erase-buffer) - (while (> index 0) - (setq index (1- index)) - (insert (ring-ref ring index) comint-input-ring-separator)) - (write-region (buffer-string) nil file nil 'no-message) - (kill-buffer nil)))))) - - -(defun comint-dynamic-list-input-ring () - "List in help buffer the buffer's input history." - (interactive) - (if (or (not (ring-p comint-input-ring)) - (ring-empty-p comint-input-ring)) - (message "No history") - (let ((history nil) - (history-buffer " *Input History*") - (index (1- (ring-length comint-input-ring))) - (conf (current-window-configuration))) - ;; We have to build up a list ourselves from the ring vector. - (while (>= index 0) - (setq history (cons (ring-ref comint-input-ring index) history) - index (1- index))) - ;; Change "completion" to "history reference" - ;; to make the display accurate. - (with-output-to-temp-buffer history-buffer - (display-completion-list history) - (set-buffer history-buffer) - (forward-line 3) - (while (search-backward "completion" nil 'move) - (replace-match "history reference"))) - (sit-for 0) - (message "Hit space to flush") - (let ((ch (read-event))) - (if (eq ch ?\ ) - (set-window-configuration conf) - (setq unread-command-events (list ch))))))) - - -(defun comint-regexp-arg (prompt) - ;; Return list of regexp and prefix arg using PROMPT. - (let* (;; Don't clobber this. - (last-command last-command) - (regexp (read-from-minibuffer prompt nil nil nil - 'minibuffer-history-search-history))) - (list (if (string-equal regexp "") - (setcar minibuffer-history-search-history - (nth 1 minibuffer-history-search-history)) - regexp) - (prefix-numeric-value current-prefix-arg)))) - -(defun comint-search-arg (arg) - ;; First make sure there is a ring and that we are after the process mark - (cond ((not (comint-after-pmark-p)) - (error "Not at command line")) - ((or (null comint-input-ring) - (ring-empty-p comint-input-ring)) - (error "Empty input ring")) - ((zerop arg) - ;; arg of zero resets search from beginning, and uses arg of 1 - (setq comint-input-ring-index nil) - 1) - (t - arg))) - -(defun comint-search-start (arg) - ;; Index to start a directional search, starting at comint-input-ring-index - (if comint-input-ring-index - ;; If a search is running, offset by 1 in direction of arg - (mod (+ comint-input-ring-index (if (> arg 0) 1 -1)) - (ring-length comint-input-ring)) - ;; For a new search, start from beginning or end, as appropriate - (if (>= arg 0) - 0 ; First elt for forward search - (1- (ring-length comint-input-ring))))) ; Last elt for backward search - -(defun comint-previous-input-string (arg) - "Return the string ARG places along the input ring. -Moves relative to `comint-input-ring-index'." - (ring-ref comint-input-ring (if comint-input-ring-index - (mod (+ arg comint-input-ring-index) - (ring-length comint-input-ring)) - arg))) - -(defun comint-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (comint-previous-matching-input "." arg)) - -(defun comint-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (comint-previous-input (- arg))) - -(defun comint-previous-matching-input-string (regexp arg) - "Return the string matching REGEXP ARG places along the input ring. -Moves relative to `comint-input-ring-index'." - (let* ((pos (comint-previous-matching-input-string-position regexp arg))) - (if pos (ring-ref comint-input-ring pos)))) - -(defun comint-previous-matching-input-string-position (regexp arg &optional start) - "Return the index matching REGEXP ARG places along the input ring. -Moves relative to START, or `comint-input-ring-index'." - (if (or (not (ring-p comint-input-ring)) - (ring-empty-p comint-input-ring)) - (error "No history")) - (let* ((len (ring-length comint-input-ring)) - (motion (if (> arg 0) 1 -1)) - (n (mod (- (or start (comint-search-start arg)) motion) len)) - (tried-each-ring-item nil) - (prev nil)) - ;; Do the whole search as many times as the argument says. - (while (and (/= arg 0) (not tried-each-ring-item)) - ;; Step once. - (setq prev n - n (mod (+ n motion) len)) - ;; If we haven't reached a match, step some more. - (while (and (< n len) (not tried-each-ring-item) - (not (string-match regexp (ring-ref comint-input-ring n)))) - (setq n (mod (+ n motion) len) - ;; If we have gone all the way around in this search. - tried-each-ring-item (= n prev))) - (setq arg (if (> arg 0) (1- arg) (1+ arg)))) - ;; Now that we know which ring element to use, if we found it, return that. - (if (string-match regexp (ring-ref comint-input-ring n)) - n))) - -(defun comint-previous-matching-input (regexp arg) - "Search backwards through input history for match for REGEXP. -\(Previous history elements are earlier commands.) -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (comint-regexp-arg "Previous input matching (regexp): ")) - (setq arg (comint-search-arg arg)) - (let ((pos (comint-previous-matching-input-string-position regexp arg))) - ;; Has a match been found? - (if (null pos) - (error "Not found") - (setq comint-input-ring-index pos) - (message "History item: %d" (1+ pos)) - (delete-region - ;; Can't use kill-region as it sets this-command - (or (marker-position comint-accum-marker) - (process-mark (get-buffer-process (current-buffer)))) - (point)) - (insert (ring-ref comint-input-ring pos))))) - -(defun comint-next-matching-input (regexp arg) - "Search forwards through input history for match for REGEXP. -\(Later history elements are more recent commands.) -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." - (interactive (comint-regexp-arg "Next input matching (regexp): ")) - (comint-previous-matching-input regexp (- arg))) - -(defun comint-previous-matching-input-from-input (arg) - "Search backwards through input history for match for current input. -\(Previous history elements are earlier commands.) -With prefix argument N, search for Nth previous match. -If N is negative, search forwards for the -Nth following match." - (interactive "p") - (if (not (memq last-command '(comint-previous-matching-input-from-input - comint-next-matching-input-from-input))) - ;; Starting a new search - (setq comint-matching-input-from-input-string - (buffer-substring - (or (marker-position comint-accum-marker) - (process-mark (get-buffer-process (current-buffer)))) - (point)) - comint-input-ring-index nil)) - (comint-previous-matching-input - (concat "^" (regexp-quote comint-matching-input-from-input-string)) - arg)) - -(defun comint-next-matching-input-from-input (arg) - "Search forwards through input history for match for current input. -\(Following history elements are more recent commands.) -With prefix argument N, search for Nth following match. -If N is negative, search backwards for the -Nth previous match." - (interactive "p") - (comint-previous-matching-input-from-input (- arg))) - - -(defun comint-replace-by-expanded-history (&optional silent start) - "Expand input command history references before point. -Expansion is dependent on the value of `comint-input-autoexpand'. - -This function depends on the buffer's idea of the input history, which may not -match the command interpreter's idea, assuming it has one. - -Assumes history syntax is like typical Un*x shells'. However, since emacs -cannot know the interpreter's idea of input line numbers, assuming it has one, -it cannot expand absolute input line number references. - -If the optional argument SILENT is non-nil, never complain -even if history reference seems erroneous. - -If the optional argument START is non-nil, that specifies the -start of the text to scan for history references, rather -than the logical beginning of line. - -See `comint-magic-space' and `comint-replace-by-expanded-history-before-point'. - -Returns t if successful." - (interactive) - (if (and comint-input-autoexpand - (if comint-use-prompt-regexp-instead-of-fields - ;; Use comint-prompt-regexp - (save-excursion - (beginning-of-line) - (looking-at (concat comint-prompt-regexp "!\\|\\^"))) - ;; Use input fields. User input that hasn't been entered - ;; yet, at the end of the buffer, has a nil `field' property. - (and (null (get-char-property (point) 'field)) - (string-match "!\\|^\\^" (field-string))))) - ;; Looks like there might be history references in the command. - (let ((previous-modified-tick (buffer-modified-tick))) - (comint-replace-by-expanded-history-before-point silent start) - (/= previous-modified-tick (buffer-modified-tick))))) - - -(defun comint-replace-by-expanded-history-before-point (silent &optional start) - "Expand directory stack reference before point. -See `comint-replace-by-expanded-history'. Returns t if successful. - -If the optional argument START is non-nil, that specifies the -start of the text to scan for history references, rather -than the logical beginning of line." - (save-excursion - (let ((toend (- (line-end-position) (point))) - (start (comint-line-beginning-position))) - (goto-char start) - (while (progn - (skip-chars-forward "^!^" (- (line-end-position) toend)) - (< (point) (- (line-end-position) toend))) - ;; This seems a bit complex. We look for references such as !!, !-num, - ;; !foo, !?foo, !{bar}, !?{bar}, ^oh, ^my^, ^god^it, ^never^ends^. - ;; If that wasn't enough, the plings can be suffixed with argument - ;; range specifiers. - ;; Argument ranges are complex too, so we hive off the input line, - ;; referenced with plings, with the range string to `comint-args'. - (setq comint-input-ring-index nil) - (cond ((or (= (preceding-char) ?\\) - (comint-within-quotes start (point))) - ;; The history is quoted, or we're in quotes. - (goto-char (1+ (point)))) - ((looking-at "![0-9]+\\($\\|[^-]\\)") - ;; We cannot know the interpreter's idea of input line numbers. - (goto-char (match-end 0)) - (message "Absolute reference cannot be expanded")) - ((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?") - ;; Just a number of args from `number' lines backward. - (let ((number (1- (string-to-number - (buffer-substring (match-beginning 1) - (match-end 1)))))) - (if (<= number (ring-length comint-input-ring)) - (progn - (replace-match - (comint-args (comint-previous-input-string number) - (match-beginning 2) (match-end 2)) - t t) - (setq comint-input-ring-index number) - (message "History item: %d" (1+ number))) - (goto-char (match-end 0)) - (message "Relative reference exceeds input history size")))) - ((or (looking-at "!!?:?\\([0-9^$*-]+\\)") (looking-at "!!")) - ;; Just a number of args from the previous input line. - (replace-match - (comint-args (comint-previous-input-string 0) - (match-beginning 1) (match-end 1)) - t t) - (message "History item: previous")) - ((looking-at - "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?") - ;; Most recent input starting with or containing (possibly - ;; protected) string, maybe just a number of args. Phew. - (let* ((mb1 (match-beginning 1)) (me1 (match-end 1)) - (mb2 (match-beginning 2)) (me2 (match-end 2)) - (exp (buffer-substring (or mb2 mb1) (or me2 me1))) - (pref (if (save-match-data (looking-at "!\\?")) "" "^")) - (pos (save-match-data - (comint-previous-matching-input-string-position - (concat pref (regexp-quote exp)) 1)))) - (if (null pos) - (progn - (goto-char (match-end 0)) - (or silent - (progn (message "Not found") - (ding)))) - (setq comint-input-ring-index pos) - (replace-match - (comint-args (ring-ref comint-input-ring pos) - (match-beginning 4) (match-end 4)) - t t) - (message "History item: %d" (1+ pos))))) - ((looking-at "\\^\\([^^]+\\)\\^?\\([^^]*\\)\\^?") - ;; Quick substitution on the previous input line. - (let ((old (buffer-substring (match-beginning 1) (match-end 1))) - (new (buffer-substring (match-beginning 2) (match-end 2))) - (pos nil)) - (replace-match (comint-previous-input-string 0) t t) - (setq pos (point)) - (goto-char (match-beginning 0)) - (if (not (search-forward old pos t)) - (or silent - (error "Not found")) - (replace-match new t t) - (message "History item: substituted")))) - (t - (forward-char 1))))))) - - -(defun comint-magic-space (arg) - "Expand input history references before point and insert ARG spaces. -A useful command to bind to SPC. See `comint-replace-by-expanded-history'." - (interactive "p") - (comint-replace-by-expanded-history) - (self-insert-command arg)) - -(defun comint-within-quotes (beg end) - "Return t if the number of quotes between BEG and END is odd. -Quotes are single and double." - (let ((countsq (comint-how-many-region "\\(^\\|[^\\\\]\\)\'" beg end)) - (countdq (comint-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end))) - (or (= (mod countsq 2) 1) (= (mod countdq 2) 1)))) - -(defun comint-how-many-region (regexp beg end) - "Return number of matches for REGEXP from BEG to END." - (let ((count 0)) - (save-excursion - (save-match-data - (goto-char beg) - (while (re-search-forward regexp end t) - (setq count (1+ count))))) - count)) - -(defun comint-args (string begin end) - ;; From STRING, return the args depending on the range specified in the text - ;; from BEGIN to END. If BEGIN is nil, assume all args. Ignore leading `:'. - ;; Range can be x-y, x-, -y, where x/y can be [0-9], *, ^, $. - (save-match-data - (if (null begin) - (comint-arguments string 0 nil) - (let* ((range (buffer-substring - (if (eq (char-after begin) ?:) (1+ begin) begin) end)) - (nth (cond ((string-match "^[*^]" range) 1) - ((string-match "^-" range) 0) - ((string-equal range "$") nil) - (t (string-to-number range)))) - (mth (cond ((string-match "[-*$]$" range) nil) - ((string-match "-" range) - (string-to-number (substring range (match-end 0)))) - (t nth)))) - (comint-arguments string nth mth))))) - -;; Return a list of arguments from ARG. Break it up at the -;; delimiters in comint-delimiter-argument-list. Returned list is backwards. -(defun comint-delim-arg (arg) - (if (null comint-delimiter-argument-list) - (list arg) - (let ((args nil) - (pos 0) - (len (length arg))) - (while (< pos len) - (let ((char (aref arg pos)) - (start pos)) - (if (memq char comint-delimiter-argument-list) - (while (and (< pos len) (eq (aref arg pos) char)) - (setq pos (1+ pos))) - (while (and (< pos len) - (not (memq (aref arg pos) - comint-delimiter-argument-list))) - (setq pos (1+ pos)))) - (setq args (cons (substring arg start pos) args)))) - args))) - -(defun comint-arguments (string nth mth) - "Return from STRING the NTH to MTH arguments. -NTH and/or MTH can be nil, which means the last argument. -Returned arguments are separated by single spaces. -We assume whitespace separates arguments, except within quotes -and except for a space or tab that immediately follows a backslash. -Also, a run of one or more of a single character -in `comint-delimiter-argument-list' is a separate argument. -Argument 0 is the command name." - ;; The first line handles ordinary characters and backslash-sequences - ;; (except with w32 msdos-like shells, where backslashes are valid). - ;; The second matches "-quoted strings. - ;; The third matches '-quoted strings. - ;; The fourth matches `-quoted strings. - ;; This seems to fit the syntax of BASH 2.0. - (let* ((first (if (and (eq system-type 'windows-nt) - (w32-shell-dos-semantics)) - "[^ \n\t\"'`]+\\|" - "[^ \n\t\"'`\\]+\\|\\\\[\"'`\\ \t]+\\|")) - (argpart (concat first - "\\(\"\\([^\"\\]\\|\\\\.\\)*\"\\|\ -'[^']*'\\|\ -`[^`]*`\\)")) - (args ()) (pos 0) - (count 0) - beg str value quotes) - ;; Build a list of all the args until we have as many as we want. - (while (and (or (null mth) (<= count mth)) - (string-match argpart string pos)) - (if (and beg (= pos (match-beginning 0))) - ;; It's contiguous, part of the same arg. - (setq pos (match-end 0) - quotes (or quotes (match-beginning 1))) - ;; It's a new separate arg. - (if beg - ;; Put the previous arg, if there was one, onto ARGS. - (setq str (substring string beg pos) - args (if quotes (cons str args) - (nconc (comint-delim-arg str) args)) - count (1+ count))) - (setq quotes (match-beginning 1)) - (setq beg (match-beginning 0)) - (setq pos (match-end 0)))) - (if beg - (setq str (substring string beg pos) - args (if quotes (cons str args) - (nconc (comint-delim-arg str) args)) - count (1+ count))) - (let ((n (or nth (1- count))) - (m (if mth (1- (- count mth)) 0))) - (mapconcat - (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " ")))) - -;; -;; Input processing stuff -;; -(defun comint-add-to-input-history (cmd) - "Add CMD to the input history. -Ignore duplicates if `comint-input-ignoredups' is non-nil." - (if (and (funcall comint-input-filter cmd) - (or (null comint-input-ignoredups) - (not (ring-p comint-input-ring)) - (ring-empty-p comint-input-ring) - (not (string-equal (ring-ref comint-input-ring 0) - cmd)))) - (ring-insert comint-input-ring cmd))) - -(defun comint-send-input () - "Send input to process. -After the process output mark, sends all text from the process mark to -point as input to the process. Before the process output mark, calls value -of variable `comint-get-old-input' to retrieve old input, copies it to the -process mark, and sends it. If variable `comint-process-echoes' is nil, -a terminal newline is also inserted into the buffer and sent to the process -\(if it is non-nil, all text from the process mark to point is deleted, -since it is assumed the remote process will re-echo it). - -Any history reference may be expanded depending on the value of the variable -`comint-input-autoexpand'. The list of function names contained in the value -of `comint-input-filter-functions' is called on the input before sending it. -The input is entered into the input history ring, if the value of variable -`comint-input-filter' returns non-nil when called on the input. - -If variable `comint-eol-on-send' is non-nil, then point is moved to the -end of line before sending the input. - -The values of `comint-get-old-input', `comint-input-filter-functions', and -`comint-input-filter' are chosen according to the command interpreter running -in the buffer. E.g., - -If the interpreter is the csh, - comint-get-old-input is the default: - If `comint-use-prompt-regexp-instead-of-fields' is nil, then - either return the current input field, if point is on an input - field, or the current line, if point is on an output field. - If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then - return the current line with any initial string matching the - regexp `comint-prompt-regexp' removed. - comint-input-filter-functions monitors input for \"cd\", \"pushd\", and - \"popd\" commands. When it sees one, it cd's the buffer. - comint-input-filter is the default: returns t if the input isn't all white - space. - -If the comint is Lucid Common Lisp, - comint-get-old-input snarfs the sexp ending at point. - comint-input-filter-functions does nothing. - comint-input-filter returns nil if the input matches input-filter-regexp, - which matches (1) all whitespace (2) :a, :c, etc. - -Similarly for Soar, Scheme, etc." - (interactive) - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (intxt (if (>= (point) (marker-position pmark)) - (progn (if comint-eol-on-send (end-of-line)) - (buffer-substring pmark (point))) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy))) - (input (if (not (eq comint-input-autoexpand 'input)) - ;; Just whatever's already there - intxt - ;; Expand and leave it visible in buffer - (comint-replace-by-expanded-history t pmark) - (buffer-substring pmark (point)))) - (history (if (not (eq comint-input-autoexpand 'history)) - input - ;; This is messy 'cos ultimately the original - ;; functions used do insertion, rather than return - ;; strings. We have to expand, then insert back. - (comint-replace-by-expanded-history t pmark) - (let ((copy (buffer-substring pmark (point))) - (start (point))) - (insert input) - (delete-region pmark start) - copy)))) - - (insert ?\n) - - (comint-add-to-input-history history) - - (run-hook-with-args 'comint-input-filter-functions - (concat input "\n")) - - (let ((beg (marker-position pmark)) - (end (1- (point)))) - (when (not (> beg end)) ; handle a special case - ;; Make an overlay for the input field - (let ((over (make-overlay beg end nil nil t))) - (unless comint-use-prompt-regexp-instead-of-fields - ;; Give old user input a field property of `input', to - ;; distinguish it from both process output and unsent - ;; input. The terminating newline is put into a special - ;; `boundary' field to make cursor movement between input - ;; and output fields smoother. - (overlay-put over 'field 'input)) - (when comint-highlight-input - (overlay-put over 'face 'comint-highlight-input) - (overlay-put over 'mouse-face 'highlight) - (overlay-put over - 'help-echo - "mouse-2: insert after prompt as new input") - (overlay-put over 'evaporate t)))) - (unless comint-use-prompt-regexp-instead-of-fields - ;; Make an overlay for the terminating newline - (let ((over (make-overlay end (1+ end) nil t nil))) - (overlay-put over 'field 'boundary) - (overlay-put over 'inhibit-line-move-field-capture t) - (overlay-put over 'evaporate t)))) - - (comint-snapshot-last-prompt) - - (setq comint-save-input-ring-index comint-input-ring-index) - (setq comint-input-ring-index nil) - ;; Update the markers before we send the input - ;; in case we get output amidst sending the input. - (set-marker comint-last-input-start pmark) - (set-marker comint-last-input-end (point)) - (set-marker (process-mark proc) (point)) - ;; clear the "accumulation" marker - (set-marker comint-accum-marker nil) - (funcall comint-input-sender proc input) - - ;; Optionally delete echoed input (after checking it). - (when comint-process-echoes - (let ((echo-len (- comint-last-input-end - comint-last-input-start))) - ;; Wait for all input to be echoed: - (while (and (accept-process-output proc) - (> (+ comint-last-input-end echo-len) - (point-max)) - (zerop - (compare-buffer-substrings - nil comint-last-input-start - (- (point-max) echo-len) - ;; Above difference is equivalent to - ;; (+ comint-last-input-start - ;; (- (point-max) comint-last-input-end)) - nil comint-last-input-end (point-max))))) - (if (and - (<= (+ comint-last-input-end echo-len) - (point-max)) - (zerop - (compare-buffer-substrings - nil comint-last-input-start comint-last-input-end - nil comint-last-input-end - (+ comint-last-input-end echo-len)))) - (delete-region comint-last-input-end - (+ comint-last-input-end echo-len))))) - - ;; This used to call comint-output-filter-functions, - ;; but that scrolled the buffer in undesirable ways. - (run-hook-with-args 'comint-output-filter-functions ""))))) - -(defvar comint-preoutput-filter-functions nil - "List of functions to call before inserting Comint output into the buffer. -Each function gets one argument, a string containing the text received -from the subprocess. It should return the string to insert, perhaps -the same string that was received, or perhaps a modified or transformed -string. - -The functions on the list are called sequentially, and each one is -given the string returned by the previous one. The string returned by -the last function is the text that is actually inserted in the -redirection buffer. - -This variable is permanent-local.") - -;; When non-nil, this is the last overlay used for output. -;; It is kept around so that we can extend it instead of creating -;; multiple contiguous overlays for multiple contiguous output chunks. -(defvar comint-last-output-overlay nil) - -;; When non-nil, this is an overlay over the last recognized prompt in -;; the buffer; it is used when highlighting the prompt. -(defvar comint-last-prompt-overlay nil) - -;; `snapshot' any current comint-last-prompt-overlay, freezing it in place. -;; Any further output will then create a new comint-last-prompt-overlay. -(defun comint-snapshot-last-prompt () - (when comint-last-prompt-overlay - (overlay-put comint-last-prompt-overlay 'evaporate t) - (setq comint-last-prompt-overlay nil))) - -(defun comint-carriage-motion (string) - "Handle carriage control characters in comint output. -Translate carriage return/linefeed sequences to linefeeds. -Make single carriage returns delete to the beginning of the line. -Make backspaces delete the previous character. - -This function should be in the list `comint-output-filter-functions'." - (save-match-data - ;; We first check to see if STRING contains any magic characters, to - ;; avoid overhead in the common case where it does not - (when (string-match "[\r\b]" string) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (save-excursion - (save-restriction - (widen) - (let ((inhibit-field-text-motion t) - (buffer-read-only nil)) - ;; CR LF -> LF - ;; Note that this won't work properly when the CR and LF - ;; are in different output chunks, but this is probably an - ;; exceedingly rare case (because they are generally - ;; written as a unit), and to delay interpretation of a - ;; trailing CR in a chunk would result in odd interactive - ;; behavior (and this case is probably far more common). - (goto-char comint-last-output-start) - (while (re-search-forward "\r$" pmark t) - (delete-char -1)) - ;; bare CR -> delete preceding line - (goto-char comint-last-output-start) - (while (search-forward "\r" pmark t) - (delete-region (point) (line-beginning-position))) - ;; BS -> delete preceding character - (goto-char comint-last-output-start) - (while (search-forward "\b" pmark t) - (delete-char -2))))))))) - -(add-hook 'comint-output-filter-functions 'comint-carriage-motion) - -;; The purpose of using this filter for comint processes -;; is to keep comint-last-input-end from moving forward -;; when output is inserted. -(defun comint-output-filter (process string) - (let ((oprocbuf (process-buffer process))) - ;; First check for killed buffer or no input. - (when (and string oprocbuf (buffer-name oprocbuf)) - (with-current-buffer oprocbuf - (comint-insert-output process string))))) - -(defun comint-insert-output (process string) - (if comint-allow-output-p - (progn - ;; Run preoutput filters - (let ((functions comint-preoutput-filter-functions)) - (while (and functions string) - (setq string (funcall (car functions) string)) - (setq functions (cdr functions)))) - - ;; Insert STRING - (let ((buffer-read-only nil) - ;; Avoid the overhead of save-excursion, since we just - ;; fiddle with the point - (saved-point (point-marker))) - - ;; The point should float after any insertion we do - (set-marker-insertion-type saved-point t) - - ;; We temporarly remove any buffer narrowing, in case the - ;; process mark is outside of the restriction - (save-restriction - (widen) - - (goto-char (process-mark process)) - (set-marker comint-last-output-start (point)) - - ;; insert-before-markers is a bad thing. XXX - ;; - ;; It is used here to force window-point markers (used to - ;; store the value of point in non-selected windows) to - ;; advance, but it also screws up any other markers that we - ;; don't _want_ to advance, such as the start-marker of some - ;; of the overlays we create. - ;; - ;; We work around the problem with the overlays by - ;; explicitly adjusting them after we do the insertion, but - ;; in the future this problem should be solved correctly, by - ;; using `insert', and making the insertion-type of - ;; window-point markers settable (via a buffer-local - ;; variable). In comint buffers, this variable would be set - ;; to `t', to cause point in non-select windows to advance. - (insert-before-markers string) - ;; Fixup markers and overlays that got screwed up because we - ;; used `insert-before-markers'. - (let ((old-point (- (point) (length string)))) - ;; comint-last-output-start - (set-marker comint-last-output-start old-point) - ;; comint-last-input-end - (when (and comint-last-input-end - (equal (marker-position comint-last-input-end) - (point))) - (set-marker comint-last-input-end old-point)) - ;; No overlays we create are set to advance upon insertion - ;; (at the start/end), so we assume that any overlay which - ;; is at the current point was incorrectly advanced by - ;; insert-before-markers. First fixup overlays that might - ;; start at point: - (dolist (over (overlays-at (point))) - (when (= (overlay-start over) (point)) - (let ((end (overlay-end over))) - (move-overlay over - old-point - (if (= end (point)) old-point end))))) - ;; Then do overlays that might end at point: - (dolist (over (overlays-at (1- (point)))) - (when (= (overlay-end over) (point)) - (move-overlay over - (min (overlay-start over) old-point) - old-point)))) - - ;; Advance process-mark - (set-marker (process-mark process) (point)) - - (unless comint-use-prompt-regexp-instead-of-fields - ;; We check to see if the last overlay used for output is - ;; adjacent to the new input, and if so, just extend it. - (if (and comint-last-output-overlay - (equal (overlay-end comint-last-output-overlay) - (marker-position comint-last-output-start))) - ;; Extend comint-last-output-overlay to include the - ;; most recent output - (move-overlay comint-last-output-overlay - (overlay-start comint-last-output-overlay) - (point)) - ;; Create a new overlay - (let ((over (make-overlay comint-last-output-start (point)))) - (overlay-put over 'field 'output) - (overlay-put over 'inhibit-line-move-field-capture t) - (overlay-put over 'evaporate t) - (setq comint-last-output-overlay over)))) - - (when comint-highlight-prompt - ;; Highlight the prompt, where we define `prompt' to mean - ;; the most recent output that doesn't end with a newline. - (unless (and (bolp) (null comint-last-prompt-overlay)) - ;; Need to create or move the prompt overlay (in the case - ;; where there is no prompt ((bolp) == t), we still do - ;; this if there's already an existing overlay). - (let ((prompt-start (save-excursion (forward-line 0) (point)))) - (if comint-last-prompt-overlay - ;; Just move an existing overlay - (move-overlay comint-last-prompt-overlay - prompt-start (point)) - ;; Need to create the overlay - (setq comint-last-prompt-overlay - (make-overlay prompt-start (point))) - (overlay-put comint-last-prompt-overlay - 'face 'comint-highlight-prompt))))) - - (goto-char saved-point) - - (run-hook-with-args 'comint-output-filter-functions string)))) - (run-hook-with-args 'comint-unallowed-output-filter-functions string))) - -(defun comint-dispatch-filter-initialize () - (setq comint-dispatch-state 'idle)) - -(defun comint-dispatch-output-filter (process input) - (let ((buffer (process-buffer process)) - (inhibit-quit nil)) ;MDJ - (if (and buffer (buffer-name buffer)) - (let ((old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (while input - (cond ((eq comint-dispatch-state 'idle) - (let ((start (string-match - comint-dispatch-escape-character - input))) - (if start - (progn - (comint-insert-output - process - (substring input 0 start)) - (setq input - (substring input (1+ start))) - (setq comint-dispatch-state 'reading-type)) - (comint-insert-output process input) - (setq input nil)))) - ((eq comint-dispatch-state 'reading-type) - (if (zerop (length input)) - (setq input nil) - (let ((char (aref input 0))) - (setq input (substring input 1)) - (let ((entry (assq char comint-dispatch-alist))) - (if entry - (funcall (nth 2 entry) (nth 1 entry)) - (progn - (comint-insert-output - process - (concat comint-dispatch-escape-character - (char-to-string char))) - (setq comint-dispatch-state 'idle))))))) - ((eq comint-dispatch-state 'reading-string) - (let ((end (string-match - comint-dispatch-string-end-regexp - input))) - (if end - (let ((string - (concat comint-string-accumulator - (substring input 0 end)))) - (setq input - (substring input (match-end 0))) - (setq comint-dispatch-state 'idle) - (funcall comint-string-receiver string)) - (setq comint-string-accumulator - (concat comint-string-accumulator input)) - (setq input nil)))) - ((eq comint-dispatch-state 'reading-to-buffer) - (let ((end (string-match - comint-dispatch-buffer-end-regexp - input))) - (if end - (progn - (save-excursion - (set-buffer comint-receiving-buffer) - (insert (substring input 0 end))) - (setq input - (substring input (match-end 0))) - (setq comint-dispatch-state 'idle) - (funcall comint-buffer-receiver - comint-receiving-buffer)) - (save-excursion - (set-buffer comint-receiving-buffer) - (insert input)) - (setq input nil)))) - (t - (error "Scheme process filter -- bad state"))))) - (set-buffer old-buffer)))))) - -(put 'comint-dispatch-output-filter 'initialize - 'comint-dispatch-filter-initialize) - -(defvar comint-dispatch-escape-character "\032" - "The escape character which introduces commands from the process. -See `comint-dispatch-output-filter'.") - -(defvar comint-dispatch-string-end-regexp "\032\\.") - -(defvar comint-dispatch-buffer-end-regexp "\032\\.") - -(defvar comint-dispatch-alist '() - "Table used to decide how to handle process filter commands. -Value is a list of entries, each entry is a list of three items. - -The first item is the character that the process filter dispatches on. -The second item is the action to be taken, a function. -The third item is the handler for the entry, a function. - -When the process filter sees a command whose character matches a -particular entry, it calls the handler with two arguments: the action -and the string containing the rest of the process filter's input -stream. It is the responsibility of the handler to invoke the action -with the appropriate arguments, and to reenter the process filter with -the remaining input.") - -(defun comint-preinput-scroll-to-bottom () - "Go to the end of buffer in all windows showing it. -Movement occurs if point in the selected window is not after the process mark, -and `this-command' is an insertion command. Insertion commands recognised -are `self-insert-command', `comint-magic-space', `yank', and `hilit-yank'. -Depends on the value of `comint-scroll-to-bottom-on-input'. - -This function should be a pre-command hook." - (if (and comint-scroll-to-bottom-on-input - (memq this-command '(self-insert-command comint-magic-space yank - hilit-yank))) - (let* ((selected (selected-window)) - (current (current-buffer)) - (process (get-buffer-process current)) - (scroll comint-scroll-to-bottom-on-input)) - (if (and process (< (point) (process-mark process))) - (if (eq scroll 'this) - (goto-char (point-max)) - (walk-windows - (function (lambda (window) - (if (and (eq (window-buffer window) current) - (or (eq scroll t) (eq scroll 'all))) - (progn - (select-window window) - (goto-char (point-max)) - (select-window selected))))) - nil t)))))) - -(defun comint-postoutput-scroll-to-bottom (string) - "Go to the end of buffer in all windows showing it. -Does not scroll if the current line is the last line in the buffer. -Depends on the value of `comint-scroll-to-bottom-on-output' and -`comint-scroll-show-maximum-output'. - -This function should be in the list `comint-output-filter-functions'." - (let* ((selected (selected-window)) - (current (current-buffer)) - (process (get-buffer-process current)) - (scroll comint-scroll-to-bottom-on-output)) - (unwind-protect - (if process - (walk-windows - (function (lambda (window) - (if (eq (window-buffer window) current) - (progn - (select-window window) - (if (and (< (point) (process-mark process)) - (or (eq scroll t) (eq scroll 'all) - ;; Maybe user wants point to jump to end. - (and (eq scroll 'this) (eq selected window)) - (and (eq scroll 'others) (not (eq selected window))) - ;; If point was at the end, keep it at end. - (and (marker-position comint-last-output-start) - (>= (point) comint-last-output-start)))) - (goto-char (process-mark process))) - ;; Optionally scroll so that the text - ;; ends at the bottom of the window. - (if (and comint-scroll-show-maximum-output - (>= (point) (process-mark process))) - (save-excursion - (goto-char (point-max)) - (recenter -1))) - (select-window selected))))) - nil t)) - (set-buffer current)))) - -(defun comint-truncate-buffer (&optional string) - "Truncate the buffer to `comint-buffer-maximum-size'. -This function could be on `comint-output-filter-functions' or bound to a key." - (interactive) - (save-excursion - (goto-char (process-mark (get-buffer-process (current-buffer)))) - (forward-line (- comint-buffer-maximum-size)) - (beginning-of-line) - (delete-region (point-min) (point)))) - -(defun comint-strip-ctrl-m (&optional string) - "Strip trailing `^M' characters from the current output group. -This function could be on `comint-output-filter-functions' or bound to a key." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (save-excursion - (condition-case nil - (goto-char - (if (interactive-p) comint-last-input-end comint-last-output-start)) - (error nil)) - (while (re-search-forward "\r+$" pmark t) - (replace-match "" t t))))) -(defalias 'shell-strip-ctrl-m 'comint-strip-ctrl-m) - -(defun comint-show-maximum-output () - "Put the end of the buffer at the bottom of the window." - (interactive) - (goto-char (point-max)) - (recenter -1)) - -(defun comint-get-old-input-default () - "Default for `comint-get-old-input'. -If `comint-use-prompt-regexp-instead-of-fields' is nil, then either -return the current input field, if point is on an input field, or the -current line, if point is on an output field. -If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then return -the current line with any initial string matching the regexp -`comint-prompt-regexp' removed." - (let ((bof (field-beginning))) - (if (eq (get-char-property bof 'field) 'input) - (field-string bof) - (comint-bol) - (buffer-substring (point) (line-end-position))))) - -(defun comint-copy-old-input () - "Insert after prompt old input at point as new input to be edited. -Calls `comint-get-old-input' to get old input." - (interactive) - (let ((input (funcall comint-get-old-input)) - (process (get-buffer-process (current-buffer)))) - (if (not process) - (error "Current buffer has no process") - (goto-char (process-mark process)) - (insert input)))) - -(defun comint-skip-prompt () - "Skip past the text matching regexp `comint-prompt-regexp'. -If this takes us past the end of the current line, don't skip at all." - (let ((eol (save-excursion (end-of-line) (point)))) - (if (and (looking-at comint-prompt-regexp) - (<= (match-end 0) eol)) - (goto-char (match-end 0))))) - -(defun comint-after-pmark-p () - "Return t if point is after the process output marker." - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (<= (marker-position pmark) (point)))) - -(defun comint-simple-send (proc string) - "Default function for sending to PROC input STRING. -This just sends STRING plus a newline. To override this, -set the hook `comint-input-sender'." - (comint-send-string proc string) - (comint-send-string proc "\n")) - -(defun comint-line-beginning-position () - "Returns the buffer position of the beginning of the line, after any prompt. -If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then the -prompt skip is done by skipping text matching the regular expression -`comint-prompt-regexp', a buffer local variable." - (if comint-use-prompt-regexp-instead-of-fields - ;; Use comint-prompt-regexp - (save-excursion - (beginning-of-line) - (comint-skip-prompt) - (point)) - ;; Use input fields. Note that, unlike the behavior of - ;; `line-beginning-position' inside a field, this function will - ;; return the position of the end of a prompt, even if the point is - ;; already inside the prompt. In order to do this, it assumes that - ;; if there are two fields on a line, then the first one is the - ;; prompt, and the second one is an input field, and is front-sticky - ;; (as input fields should be). - (constrain-to-field (line-beginning-position) (line-end-position)))) - -(defun comint-bol (&optional arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If prefix argument is given (\\[universal-argument]) the prompt is not skipped. -If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then the -prompt skip is done by skipping text matching the regular expression -`comint-prompt-regexp', a buffer local variable." - (interactive "P") - (if arg - ;; Unlike `beginning-of-line', forward-line ignores field boundaries - (forward-line 0) - (goto-char (comint-line-beginning-position)))) - -;; These three functions are for entering text you don't want echoed or -;; saved -- typically passwords to ftp, telnet, or somesuch. -;; Just enter m-x send-invisible and type in your line, or add -;; `comint-watch-for-password-prompt' to `comint-output-filter-functions'. - -(defun comint-read-noecho (prompt &optional stars) - "Read a single line of text from user without echoing, and return it. -Prompt with argument PROMPT, a string. Optional argument STARS causes -input to be echoed with '*' characters on the prompt line. Input ends with -RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. C-g aborts (if -`inhibit-quit' is set because e.g. this function was called from a process -filter and C-g is pressed, this function returns nil rather than a string). - -Note that the keystrokes comprising the text can still be recovered -\(temporarily) with \\[view-lossage]. Some people find this worrysome. -Once the caller uses the password, it can erase the password -by doing (fillarray STRING 0)." - (let ((ans "") - (newans nil) - (c 0) - (echo-keystrokes 0) - (cursor-in-echo-area t) - (message-log-max nil) - (done nil)) - (while (not done) - (if stars - (message "%s%s" prompt (make-string (length ans) ?*)) - (message "%s" prompt)) - ;; Use this instead of `read-char' to avoid "Non-character input-event". - (setq c (read-char-exclusive)) - (cond ((= c ?\C-g) - ;; This function may get called from a process filter, where - ;; inhibit-quit is set. In later versions of emacs read-char - ;; may clear quit-flag itself and return C-g. That would make - ;; it impossible to quit this loop in a simple way, so - ;; re-enable it here (for backward-compatibility the check for - ;; quit-flag below would still be necessary, so this seems - ;; like the simplest way to do things). - (setq quit-flag t - done t)) - ((or (= c ?\r) (= c ?\n) (= c ?\e)) - (setq done t)) - ((= c ?\C-u) - (fillarray ans 0) - (setq ans "")) - ((and (/= c ?\b) (/= c ?\177)) - (setq newans (concat ans (char-to-string c))) - (fillarray ans 0) - (setq ans newans)) - ((> (length ans) 0) - (aset ans (1- (length ans)) 0) - (setq ans (substring ans 0 -1))))) - (if quit-flag - ;; Emulate a true quit, except that we have to return a value. - (prog1 - (setq quit-flag nil) - (message "Quit") - (beep t)) - (message "") - ans))) - -(defun send-invisible (str) - "Read a string without echoing. -Then send it to the process running in the current buffer. -The string is sent using `comint-input-sender'. -Security bug: your string can still be temporarily recovered with -\\[view-lossage]." - (interactive "P") ; Defeat snooping via C-x ESC ESC - (let ((proc (get-buffer-process (current-buffer)))) - (cond ((not proc) - (error "Current buffer has no process")) - ((stringp str) - (comint-snapshot-last-prompt) - (funcall comint-input-sender proc str)) - (t - (let ((str (comint-read-noecho "Non-echoed text: " t))) - (if (stringp str) - (send-invisible str) - (message "Warning: text will be echoed"))))))) - -(defun comint-watch-for-password-prompt (string) - "Prompt in the minibuffer for password and send without echoing. -This function uses `send-invisible' to read and send a password to the buffer's -process if STRING contains a password prompt defined by -`comint-password-prompt-regexp'. - -This function could be in the list `comint-output-filter-functions'." - (when (string-match comint-password-prompt-regexp string) - (let ((pw (comint-read-noecho string t))) - (send-invisible pw)))) - -;; Low-level process communication - -(defun comint-send-string (process string) - "Like `process-send-string', but also does extra bookkeeping for comint mode." - (if process - (with-current-buffer (if (processp process) - (process-buffer process) - (get-buffer process)) - (comint-snapshot-last-prompt)) - (comint-snapshot-last-prompt)) - (process-send-string process string)) - -(defun comint-send-region (process start end) - "Like `process-send-region', but also does extra bookkeeping for comint mode." - (if process - (with-current-buffer (if (processp process) - (process-buffer process) - (get-buffer process)) - (comint-snapshot-last-prompt)) - (comint-snapshot-last-prompt)) - (process-send-region process start end)) - -;; Random input hackage - -(defun comint-delete-output () - "Delete all output from interpreter since last input. -Does not delete the prompt." - (interactive) - (let ((proc (get-buffer-process (current-buffer))) - (replacement nil)) - (save-excursion - (let ((pmark (progn (goto-char (process-mark proc)) - (forward-line 0) - (point-marker)))) - (delete-region comint-last-input-end pmark) - (goto-char (process-mark proc)) - (setq replacement (concat "*** output flushed ***\n" - (buffer-substring pmark (point)))) - (delete-region pmark (point)))) - ;; Output message and put back prompt - (comint-output-filter proc replacement))) -(defalias 'comint-kill-output 'comint-delete-output) -(make-obsolete 'comint-kill-output 'comint-delete-output "21.1") - -(defun comint-write-output (filename &optional append mustbenew) - "Write output from interpreter since last input to FILENAME. -Any prompt at the end of the output is not written. - -If the optional argument APPEND (the prefix argument when interactive) -is non-nil, the output is appended to the file instead. - -If the optional argument MUSTBENEW is non-nil, check for an existing -file with the same name. If MUSTBENEW is `excl', that means to get an -error if the file already exists; never overwrite. If MUSTBENEW is -neither nil nor `excl', that means ask for confirmation before -overwriting, but do go ahead and overwrite the file if the user -confirms. When interactive, MUSTBENEW is nil when appending, and t -otherwise." - (interactive - (list (read-file-name - (if current-prefix-arg - "Append output to file: " - "Write output to file: ")) - current-prefix-arg - (not current-prefix-arg))) - (save-excursion - (goto-char (process-mark (get-buffer-process (current-buffer)))) - (forward-line 0) - (write-region comint-last-input-end (point) filename - append nil nil mustbenew))) - -;; This function exists for the benefit of the menu; from the keyboard, -;; users can just use `comint-write-output' with a prefix arg. -(defun comint-append-output-to-file (filename) - "Append output from interpreter since last input to FILENAME. -Any prompt at the end of the output is not written." - (interactive "fAppend output to file: ") - (comint-write-output filename t)) - -(defun comint-show-output () - "Display start of this batch of interpreter output at top of window. -Sets mark to the value of point when this command is run." - (interactive) - (push-mark) - (let ((pos (or (marker-position comint-last-input-end) (point-max)))) - (cond (comint-use-prompt-regexp-instead-of-fields - (goto-char pos) - (beginning-of-line 0) - (set-window-start (selected-window) (point)) - (comint-skip-prompt)) - (t - (goto-char (field-beginning pos)) - (set-window-start (selected-window) (point)))))) - - -(defun comint-interrupt-subjob () - "Interrupt the current subjob. -This command also kills the pending input -between the process-mark and point." - (interactive) - (comint-kill-input) - (interrupt-process nil comint-ptyp)) - -(defun comint-kill-subjob () - "Send kill signal to the current subjob. -This command also kills the pending input -between the process-mark and point." - (interactive) - (comint-kill-input) - (kill-process nil comint-ptyp)) - -(defun comint-quit-subjob () - "Send quit signal to the current subjob. -This command also kills the pending input -between the process-mark and point." - (interactive) - (comint-kill-input) - (quit-process nil comint-ptyp)) - -(defun comint-stop-subjob () - "Stop the current subjob. -This command also kills the pending input -between the process-mark and point. - -WARNING: if there is no current subjob, you can end up suspending -the top-level process running in the buffer. If you accidentally do -this, use \\[comint-continue-subjob] to resume the process. (This -is not a problem with most shells, since they ignore this signal.)" - (interactive) - (comint-kill-input) - (stop-process nil comint-ptyp)) - -(defun comint-continue-subjob () - "Send CONT signal to process buffer's process group. -Useful if you accidentally suspend the top-level process." - (interactive) - (continue-process nil comint-ptyp)) - -(defun comint-kill-input () - "Kill all text from last stuff output by interpreter to point." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (if (> (point) (marker-position pmark)) - (kill-region pmark (point))))) - -(defun comint-delchar-or-maybe-eof (arg) - "Delete ARG characters forward or send an EOF to subprocess. -Sends an EOF only if point is at the end of the buffer and there is no input." - (interactive "p") - (let ((proc (get-buffer-process (current-buffer)))) - (if (and (eobp) proc (= (point) (marker-position (process-mark proc)))) - (comint-send-eof) - (delete-char arg)))) - -(defun comint-send-eof () - "Send an EOF to the current buffer's process." - (interactive) - (comint-snapshot-last-prompt) - (process-send-eof)) - - -(defun comint-backward-matching-input (regexp arg) - "Search backward through buffer for input fields that match REGEXP. -If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then input -fields are identified by lines that match `comint-prompt-regexp'. - -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (comint-regexp-arg "Backward input matching (regexp): ")) - (if comint-use-prompt-regexp-instead-of-fields - ;; Use comint-prompt-regexp - (let* ((re (concat comint-prompt-regexp ".*" regexp)) - (pos (save-excursion (end-of-line (if (> arg 0) 0 1)) - (if (re-search-backward re nil t arg) - (point))))) - (if (null pos) - (progn (message "Not found") - (ding)) - (goto-char pos) - (comint-bol nil))) - ;; Use input fields - (let* ((dir (if (< arg 0) -1 1)) - (pos - (save-excursion - (while (/= arg 0) - (unless (re-search-backward regexp nil t dir) - (error "Not found")) - (when (eq (get-char-property (point) 'field) 'input) - (setq arg (- arg dir)))) - (field-beginning)))) - (goto-char pos)))) - - -(defun comint-forward-matching-input (regexp arg) - "Search forward through buffer for input fields that match REGEXP. -If `comint-use-prompt-regexp-instead-of-fields' is non-nil, then input -fields are identified by lines that match `comint-prompt-regexp'. - -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." - (interactive (comint-regexp-arg "Forward input matching (regexp): ")) - (comint-backward-matching-input regexp (- arg))) - - -(defun comint-next-prompt (n) - "Move to end of Nth next prompt in the buffer. -If `comint-use-prompt-regexp-instead-of-fields' is nil, then this means -the beginning of the Nth next `input' field, otherwise, it means the Nth -occurance of text matching `comint-prompt-regexp'." - (interactive "p") - (if comint-use-prompt-regexp-instead-of-fields - ;; Use comint-prompt-regexp - (let ((paragraph-start comint-prompt-regexp)) - (end-of-line (if (> n 0) 1 0)) - (forward-paragraph n) - (comint-skip-prompt)) - ;; Use input fields - (let ((pos (point)) - (input-pos nil) - prev-pos) - (while (/= n 0) - (setq prev-pos pos) - (setq pos - (if (> n 0) - (next-single-char-property-change pos 'field) - (previous-single-char-property-change pos 'field))) - (cond ((or (null pos) (= pos prev-pos)) - ;; Ran off the end of the buffer. - (when (> n 0) - ;; There's always an input field at the end of the - ;; buffer, but it has a `field' property of nil. - (setq input-pos (point-max))) - ;; stop iterating - (setq n 0)) - ((eq (get-char-property pos 'field) 'input) - (setq n (if (< n 0) (1+ n) (1- n))) - (setq input-pos pos)))) - (when input-pos - (goto-char input-pos))))) - - -(defun comint-previous-prompt (n) - "Move to end of Nth previous prompt in the buffer. -If `comint-use-prompt-regexp-instead-of-fields' is nil, then this means -the beginning of the Nth previous `input' field, otherwise, it means the Nth -occurance of text matching `comint-prompt-regexp'." - (interactive "p") - (comint-next-prompt (- n))) - -;; Support for source-file processing commands. -;;============================================================================ -;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have -;; commands that process files of source text (e.g. loading or compiling -;; files). So the corresponding process-in-a-buffer modes have commands -;; for doing this (e.g., lisp-load-file). The functions below are useful -;; for defining these commands. -;; -;; Alas, these guys don't do exactly the right thing for Lisp, Scheme -;; and Soar, in that they don't know anything about file extensions. -;; So the compile/load interface gets the wrong default occasionally. -;; The load-file/compile-file default mechanism could be smarter -- it -;; doesn't know about the relationship between filename extensions and -;; whether the file is source or executable. If you compile foo.lisp -;; with compile-file, then the next load-file should use foo.bin for -;; the default, not foo.lisp. This is tricky to do right, particularly -;; because the extension for executable files varies so much (.o, .bin, -;; .lbin, .mo, .vo, .ao, ...). - - -;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing -;; commands. -;; -;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you -;; want to save the buffer before issuing any process requests to the command -;; interpreter. -;; -;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt -;; for the file to process. - -;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) -;;============================================================================ -;; This function computes the defaults for the load-file and compile-file -;; commands for tea, soar, cmulisp, and cmuscheme modes. -;; -;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last -;; source-file processing command. NIL if there hasn't been one yet. -;; - SOURCE-MODES is a list used to determine what buffers contain source -;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. -;; Typically, (lisp-mode) or (scheme-mode). -;; -;; If the command is given while the cursor is inside a string, *and* -;; the string is an existing filename, *and* the filename is not a directory, -;; then the string is taken as default. This allows you to just position -;; your cursor over a string that's a filename and have it taken as default. -;; -;; If the command is given in a file buffer whose major mode is in -;; SOURCE-MODES, then the the filename is the default file, and the -;; file's directory is the default directory. -;; -;; If the buffer isn't a source file buffer (e.g., it's the process buffer), -;; then the default directory & file are what was used in the last source-file -;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time -;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory -;; is the cwd, with no default file. (\"no default file\" = nil) -;; -;; SOURCE-REGEXP is typically going to be something like (tea-mode) -;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) -;; for Soar programs, etc. -;; -;; The function returns a pair: (default-directory . default-file). - -(defun comint-source-default (previous-dir/file source-modes) - (cond ((and buffer-file-name (memq major-mode source-modes)) - (cons (file-name-directory buffer-file-name) - (file-name-nondirectory buffer-file-name))) - (previous-dir/file) - (t - (cons default-directory nil)))) - - -;; (COMINT-CHECK-SOURCE fname) -;;============================================================================ -;; Prior to loading or compiling (or otherwise processing) a file (in the CMU -;; process-in-a-buffer modes), this function can be called on the filename. -;; If the file is loaded into a buffer, and the buffer is modified, the user -;; is queried to see if he wants to save the buffer before proceeding with -;; the load or compile. - -(defun comint-check-source (fname) - (let ((buff (get-file-buffer fname))) - (if (and buff - (buffer-modified-p buff) - (y-or-n-p (format "Save buffer %s first? " (buffer-name buff)))) - ;; save BUFF. - (let ((old-buffer (current-buffer))) - (set-buffer buff) - (save-buffer) - (set-buffer old-buffer))))) - - -;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) -;;============================================================================ -;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter -;; commands that process source files (like loading or compiling a file). -;; It prompts for the filename, provides a default, if there is one, -;; and returns the result filename. -;; -;; See COMINT-SOURCE-DEFAULT for more on determining defaults. -;; -;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair -;; from the last source processing command. SOURCE-MODES is a list of major -;; modes used to determine what file buffers contain source files. (These -;; two arguments are used for determining defaults). If MUSTMATCH-P is true, -;; then the filename reader will only accept a file that exists. -;; -;; A typical use: -;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file -;; '(lisp-mode) t)) - -;; This is pretty stupid about strings. It decides we're in a string -;; if there's a quote on both sides of point on the current line. -(defun comint-extract-string () - "Return string around POINT that starts the current line, or nil." - (save-excursion - (let* ((point (point)) - (bol (progn (beginning-of-line) (point))) - (eol (progn (end-of-line) (point))) - (start (progn (goto-char point) - (and (search-backward "\"" bol t) - (1+ (point))))) - (end (progn (goto-char point) - (and (search-forward "\"" eol t) - (1- (point)))))) - (and start end - (buffer-substring start end))))) - -(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) - (let* ((def (comint-source-default prev-dir/file source-modes)) - (stringfile (comint-extract-string)) - (sfile-p (and stringfile - (condition-case () - (file-exists-p stringfile) - (error nil)) - (not (file-directory-p stringfile)))) - (defdir (if sfile-p (file-name-directory stringfile) - (car def))) - (deffile (if sfile-p (file-name-nondirectory stringfile) - (cdr def))) - (ans (read-file-name (if deffile (format "%s(default %s) " - prompt deffile) - prompt) - defdir - (concat defdir deffile) - mustmatch-p))) - (list (expand-file-name (substitute-in-file-name ans))))) - -;; I am somewhat divided on this string-default feature. It seems -;; to violate the principle-of-least-astonishment, in that it makes -;; the default harder to predict, so you actually have to look and see -;; what the default really is before choosing it. This can trip you up. -;; On the other hand, it can be useful, I guess. I would appreciate feedback -;; on this. -;; -Olin - - -;; Simple process query facility. -;; =========================================================================== -;; This function is for commands that want to send a query to the process -;; and show the response to the user. For example, a command to get the -;; arglist for a Common Lisp function might send a "(arglist 'foo)" query -;; to an inferior Common Lisp process. -;; -;; This simple facility just sends strings to the inferior process and pops -;; up a window for the process buffer so you can see what the process -;; responds with. We don't do anything fancy like try to intercept what the -;; process responds with and put it in a pop-up window or on the message -;; line. We just display the buffer. Low tech. Simple. Works good. - -;; Send to the inferior process PROC the string STR. Pop-up but do not select -;; a window for the inferior process so that its response can be seen. -(defun comint-proc-query (proc str) - (let* ((proc-buf (process-buffer proc)) - (proc-mark (process-mark proc))) - (display-buffer proc-buf) - (set-buffer proc-buf) ; but it's not the selected *window* - (let ((proc-win (get-buffer-window proc-buf)) - (proc-pt (marker-position proc-mark))) - (comint-send-string proc str) ; send the query - (accept-process-output proc) ; wait for some output - ;; Try to position the proc window so you can see the answer. - ;; This is bogus code. If you delete the (sit-for 0), it breaks. - ;; I don't know why. Wizards invited to improve it. - (unless (pos-visible-in-window-p proc-pt proc-win) - (let ((opoint (window-point proc-win))) - (set-window-point proc-win proc-mark) - (sit-for 0) - (if (not (pos-visible-in-window-p opoint proc-win)) - (push-mark opoint) - (set-window-point proc-win opoint))))))) - - -;; Filename/command/history completion in a buffer -;; =========================================================================== -;; Useful completion functions, courtesy of the Ergo group. - -;; Six commands: -;; comint-dynamic-complete Complete or expand command, filename, -;; history at point. -;; comint-dynamic-complete-filename Complete filename at point. -;; comint-dynamic-list-filename-completions List completions in help buffer. -;; comint-replace-by-expanded-filename Expand and complete filename at point; -;; replace with expanded/completed name. -;; comint-dynamic-simple-complete Complete stub given candidates. - -;; These are not installed in the comint-mode keymap. But they are -;; available for people who want them. Shell-mode installs them: -;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) -;; (define-key shell-mode-map "\M-?" -;; 'comint-dynamic-list-filename-completions))) -;; -;; Commands like this are fine things to put in load hooks if you -;; want them present in specific modes. - -(defcustom comint-completion-autolist nil - "*If non-nil, automatically list possibilities on partial completion. -This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'comint-completion) - -(defcustom comint-completion-addsuffix t - "*If non-nil, add a `/' to completed directories, ` ' to file names. -If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where -DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact completion. -This mirrors the optional behavior of tcsh." - :type '(choice (const :tag "None" nil) - (const :tag "Add /" t) - (cons :tag "Suffix pair" - (string :tag "Directory suffix") - (string :tag "File suffix"))) - :group 'comint-completion) - -(defcustom comint-completion-recexact nil - "*If non-nil, use shortest completion if characters cannot be added. -This mirrors the optional behavior of tcsh. - -A non-nil value is useful if `comint-completion-autolist' is non-nil too." - :type 'boolean - :group 'comint-completion) - -(defcustom comint-completion-fignore nil - "*List of suffixes to be disregarded during file completion. -This mirrors the optional behavior of bash and tcsh. - -Note that this applies to `comint-dynamic-complete-filename' only." - :type '(repeat (string :tag "Suffix")) - :group 'comint-completion) - -(defvar comint-file-name-prefix "" - "Prefix prepended to absolute file names taken from process input. -This is used by comint's and shell's completion functions, and by shell's -directory tracking functions.") - -(defvar comint-file-name-chars - (if (memq system-type '(ms-dos windows-nt)) - "~/A-Za-z0-9_^$!#%&{}@`'.,:()-" - "~/A-Za-z0-9+@:_.$#%,={}-") - "String of characters valid in a file name. -Note that all non-ASCII characters are considered valid in a file name -regardless of what this variable says. - -This is a good thing to set in mode hooks.") - -(defvar comint-file-name-quote-list nil - "List of characters to quote with `\\' when in a file name. - -This is a good thing to set in mode hooks.") - - -(defun comint-directory (directory) - ;; Return expanded DIRECTORY, with `comint-file-name-prefix' if absolute. - (expand-file-name (if (file-name-absolute-p directory) - (concat comint-file-name-prefix directory) - directory))) - - -(defun comint-word (word-chars) - "Return the word of WORD-CHARS at point, or nil if non is found. -Word constituents are considered to be those in WORD-CHARS, which is like the -inside of a \"[...]\" (see `skip-chars-forward'), -plus all non-ASCII characters." - (save-excursion - (let ((non-word-chars (concat "[^\\\\" word-chars "]")) (here (point))) - (while (and (re-search-backward non-word-chars nil 'move) - ;;(memq (char-after (point)) shell-file-name-quote-list) - (or (>= (following-char) 128) - (eq (preceding-char) ?\\))) - (backward-char 1)) - ;; Don't go forward over a word-char (this can happen if we're at bob). - (when (or (not (bobp)) (looking-at non-word-chars)) - (forward-char 1)) - ;; Set match-data to match the entire string. - (when (< (point) here) - (set-match-data (list (point) here)) - (match-string 0))))) - -(defun comint-substitute-in-file-name (filename) - "Return FILENAME with environment variables substituted. -Supports additional environment variable syntax of the command -interpreter (e.g., the percent notation of cmd.exe on NT)." - (let ((name (substitute-in-file-name filename))) - (if (memq system-type '(ms-dos windows-nt)) - (let (env-var-name - env-var-val) - (save-match-data - (while (string-match "%\\([^\\\\/]*\\)%" name) - (setq env-var-name - (substring name (match-beginning 1) (match-end 1))) - (setq env-var-val (if (getenv env-var-name) - (getenv env-var-name) - "")) - (setq name (replace-match env-var-val t t name)))))) - name)) - -(defun comint-match-partial-filename () - "Return the filename at point, or nil if non is found. -Environment variables are substituted. See `comint-word'." - (let ((filename (comint-word comint-file-name-chars))) - (and filename (comint-substitute-in-file-name - (comint-unquote-filename filename))))) - - -(defun comint-quote-filename (filename) - "Return FILENAME with magic characters quoted. -Magic characters are those in `comint-file-name-quote-list'." - (if (null comint-file-name-quote-list) - filename - (let ((regexp - (format "\\(^\\|[^\\]\\)\\([%s]\\)" - (mapconcat 'char-to-string comint-file-name-quote-list "")))) - (save-match-data - (while (string-match regexp filename) - (setq filename (replace-match "\\1\\\\\\2" nil nil filename))) - filename)))) - -(defun comint-unquote-filename (filename) - "Return FILENAME with quoted characters unquoted." - (if (null comint-file-name-quote-list) - filename - (save-match-data - (let ((i 0)) - (while (string-match "\\\\\\(.\\)" filename i) - (setq filename (replace-match "\\1" nil nil filename)) - (setq i (+ 1 (match-beginning 0))))) - filename))) - - -(defun comint-dynamic-complete () - "Dynamically perform completion at point. -Calls the functions in `comint-dynamic-complete-functions' to perform -completion until a function returns non-nil, at which point completion is -assumed to have occurred." - (interactive) - (run-hook-with-args-until-success 'comint-dynamic-complete-functions)) - - -(defun comint-dynamic-complete-filename () - "Dynamically complete the filename at point. -Completes if after a filename. See `comint-match-partial-filename' and -`comint-dynamic-complete-as-filename'. -This function is similar to `comint-replace-by-expanded-filename', except that -it won't change parts of the filename already entered in the buffer; it just -adds completion characters to the end of the filename. A completions listing -may be shown in a help buffer if completion is ambiguous. - -Completion is dependent on the value of `comint-completion-addsuffix', -`comint-completion-recexact' and `comint-completion-fignore', and the timing of -completions listing is dependent on the value of `comint-completion-autolist'. - -Returns t if successful." - (interactive) - (when (comint-match-partial-filename) - (unless (window-minibuffer-p (selected-window)) - (message "Completing file name...")) - (comint-dynamic-complete-as-filename))) - -(defun comint-dynamic-complete-as-filename () - "Dynamically complete at point as a filename. -See `comint-dynamic-complete-filename'. Returns t if successful." - (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt))) - (completion-ignored-extensions comint-completion-fignore) - ;; If we bind this, it breaks remote directory tracking in rlogin.el. - ;; I think it was originally bound to solve file completion problems, - ;; but subsequent changes may have made this unnecessary. sm. - ;;(file-name-handler-alist nil) - (minibuffer-p (window-minibuffer-p (selected-window))) - (success t) - (dirsuffix (cond ((not comint-completion-addsuffix) - "") - ((not (consp comint-completion-addsuffix)) - (char-to-string directory-sep-char)) - (t - (car comint-completion-addsuffix)))) - (filesuffix (cond ((not comint-completion-addsuffix) - "") - ((not (consp comint-completion-addsuffix)) - " ") - (t - (cdr comint-completion-addsuffix)))) - (filename (or (comint-match-partial-filename) "")) - (pathdir (file-name-directory filename)) - (pathnondir (file-name-nondirectory filename)) - (directory (if pathdir (comint-directory pathdir) default-directory)) - (completion (file-name-completion pathnondir directory))) - (cond ((null completion) - (message "No completions of %s" filename) - (setq success nil)) - ((eq completion t) ; Means already completed "file". - (insert filesuffix) - (unless minibuffer-p - (message "Sole completion"))) - ((string-equal completion "") ; Means completion on "directory/". - (comint-dynamic-list-filename-completions)) - (t ; Completion string returned. - (let ((file (concat (file-name-as-directory directory) completion))) - (insert (comint-quote-filename - (substring (directory-file-name completion) - (length pathnondir)))) - (cond ((symbolp (file-name-completion completion directory)) - ;; We inserted a unique completion. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (unless minibuffer-p - (message "Completed"))) - ((and comint-completion-recexact comint-completion-addsuffix - (string-equal pathnondir completion) - (file-exists-p file)) - ;; It's not unique, but user wants shortest match. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (unless minibuffer-p - (message "Completed shortest"))) - ((or comint-completion-autolist - (string-equal pathnondir completion)) - ;; It's not unique, list possible completions. - (comint-dynamic-list-filename-completions)) - (t - (unless minibuffer-p - (message "Partially completed"))))))) - success)) - - -(defun comint-replace-by-expanded-filename () - "Dynamically expand and complete the filename at point. -Replace the filename with an expanded, canonicalised and completed replacement. -\"Expanded\" means environment variables (e.g., $HOME) and `~'s are replaced -with the corresponding directories. \"Canonicalised\" means `..' and `.' are -removed, and the filename is made absolute instead of relative. For expansion -see `expand-file-name' and `substitute-in-file-name'. For completion see -`comint-dynamic-complete-filename'." - (interactive) - (replace-match (expand-file-name (comint-match-partial-filename)) t t) - (comint-dynamic-complete-filename)) - - -(defun comint-dynamic-simple-complete (stub candidates) - "Dynamically complete STUB from CANDIDATES list. -This function inserts completion characters at point by completing STUB from -the strings in CANDIDATES. A completions listing may be shown in a help buffer -if completion is ambiguous. - -Returns nil if no completion was inserted. -Returns `sole' if completed with the only completion match. -Returns `shortest' if completed with the shortest of the completion matches. -Returns `partial' if completed as far as possible with the completion matches. -Returns `listed' if a completion listing was shown. - -See also `comint-dynamic-complete-filename'." - (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt))) - (suffix (cond ((not comint-completion-addsuffix) "") - ((not (consp comint-completion-addsuffix)) " ") - (t (cdr comint-completion-addsuffix)))) - (candidates (mapcar (function (lambda (x) (list x))) candidates)) - (completions (all-completions stub candidates))) - (cond ((null completions) - (message "No completions of %s" stub) - nil) - ((= 1 (length completions)) ; Gotcha! - (let ((completion (car completions))) - (if (string-equal completion stub) - (message "Sole completion") - (insert (substring completion (length stub))) - (message "Completed")) - (insert suffix) - 'sole)) - (t ; There's no unique completion. - (let ((completion (try-completion stub candidates))) - ;; Insert the longest substring. - (insert (substring completion (length stub))) - (cond ((and comint-completion-recexact comint-completion-addsuffix - (string-equal stub completion) - (member completion completions)) - ;; It's not unique, but user wants shortest match. - (insert suffix) - (message "Completed shortest") - 'shortest) - ((or comint-completion-autolist - (string-equal stub completion)) - ;; It's not unique, list possible completions. - (comint-dynamic-list-completions completions) - 'listed) - (t - (message "Partially completed") - 'partial))))))) - - -(defun comint-dynamic-list-filename-completions () - "List in help buffer possible completions of the filename at point." - (interactive) - (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt))) - ;; If we bind this, it breaks remote directory tracking in rlogin.el. - ;; I think it was originally bound to solve file completion problems, - ;; but subsequent changes may have made this unnecessary. sm. - ;;(file-name-handler-alist nil) - (filename (or (comint-match-partial-filename) "")) - (pathdir (file-name-directory filename)) - (pathnondir (file-name-nondirectory filename)) - (directory (if pathdir (comint-directory pathdir) default-directory)) - (completions (file-name-all-completions pathnondir directory))) - (if (not completions) - (message "No completions of %s" filename) - (comint-dynamic-list-completions - (mapcar 'comint-quote-filename completions))))) - - -(defun comint-dynamic-list-completions (completions) - "List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." - (let ((conf (current-window-configuration))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (sort completions 'string-lessp))) - (message "Hit space to flush") - (let (key first) - (if (save-excursion - (set-buffer (get-buffer "*Completions*")) - (setq key (read-key-sequence nil) - first (aref key 0)) - (and (consp first) (consp (event-start first)) - (eq (window-buffer (posn-window (event-start first))) - (get-buffer "*Completions*")) - (eq (key-binding key) 'mouse-choose-completion))) - ;; If the user does mouse-choose-completion with the mouse, - ;; execute the command, then delete the completion window. - (progn - (mouse-choose-completion first) - (set-window-configuration conf)) - (if (eq first ?\ ) - (set-window-configuration conf) - (setq unread-command-events (listify-key-sequence key))))))) - -(defun comint-get-next-from-history () - "After fetching a line from input history, this fetches the following line. -In other words, this recalls the input line after the line you recalled last. -You can use this to repeat a sequence of input lines." - (interactive) - (if comint-save-input-ring-index - (progn - (setq comint-input-ring-index (1+ comint-save-input-ring-index)) - (comint-next-input 1)) - (message "No previous history command"))) - -(defun comint-accumulate () - "Accumulate a line to send as input along with more lines. -This inserts a newline so that you can enter more text -to be sent along with this line. Use \\[comint-send-input] -to send all the accumulated input, at once. -The entire accumulated text becomes one item in the input history -when you send it." - (interactive) - (insert "\n") - (set-marker comint-accum-marker (point)) - (if comint-input-ring-index - (setq comint-save-input-ring-index - (- comint-input-ring-index 1)))) - -(defun comint-goto-process-mark () - "Move point to the process mark. -The process mark separates output, and input already sent, -from input that has not yet been sent." - (interactive) - (let ((proc (or (get-buffer-process (current-buffer)) - (error "Current buffer has no process")))) - (goto-char (process-mark proc)) - (when (interactive-p) - (message "Point is now at the process mark")))) - -(defun comint-bol-or-process-mark () - "Move point to beginning of line (after prompt) or to the process mark. -The first time you use this command, it moves to the beginning of the line -\(but after the prompt, if any). If you repeat it again immediately, -it moves point to the process mark. - -The process mark separates the process output, along with input already sent, -from input that has not yet been sent. Ordinarily, the process mark -is at the beginning of the current input line; but if you have -used \\[comint-accumulate] to send multiple lines at once, -the process mark is at the beginning of the accumulated input." - (interactive) - (if (not (eq last-command 'comint-bol-or-process-mark)) - (comint-bol nil) - (comint-goto-process-mark))) - -(defun comint-set-process-mark () - "Set the process mark at point." - (interactive) - (let ((proc (or (get-buffer-process (current-buffer)) - (error "Current buffer has no process")))) - (set-marker (process-mark proc) (point)) - (message "Process mark set"))) - - -;; Author: Peter Breton - -;; This little add-on for comint is intended to make it easy to get -;; output from currently active comint buffers into another buffer, -;; or buffers, and then go back to using the comint shell. -;; -;; My particular use is SQL interpreters; I want to be able to execute a -;; query using the process associated with a comint-buffer, and save that -;; somewhere else. Because the process might have state (for example, it -;; could be in an uncommitted transaction), just running starting a new -;; process and having it execute the query and then finish, would not -;; work. I'm sure there are other uses as well, although in many cases -;; starting a new process is the simpler, and thus preferable, approach. -;; -;; The basic implementation is as follows: comint-redirect changes the -;; preoutput filter functions (comint-preoutput-filter-functions) to use -;; its own filter. The filter puts the output into the designated buffer, -;; or buffers, until it sees a regexp that tells it to stop (by default, -;; this is the prompt for the interpreter, comint-prompt-regexp). When it -;; sees the stop regexp, it restores the old filter functions, and runs -;; comint-redirect-hook. -;; -;; Each comint buffer may only use one redirection at a time, but any number -;; of different comint buffers may be simultaneously redirected. -;; -;; NOTE: It is EXTREMELY important that `comint-prompt-regexp' be set to the -;; correct prompt for your interpreter, or that you supply a regexp that says -;; when the redirection is finished. Otherwise, redirection will continue -;; indefinitely. The code now does a sanity check to ensure that it can find -;; a prompt in the comint buffer; however, it is still important to ensure that -;; this prompt is set correctly. -;; -;; XXX: This doesn't work so well unless comint-prompt-regexp is set; -;; perhaps it should prompt for a terminating string (with an -;; appropriate magic default by examining what we think is the prompt)? -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Variables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defcustom comint-redirect-verbose nil - "*If non-nil, print messages each time the redirection filter is invoked. -Also print a message when redirection is completed." - :group 'comint - :type 'boolean) - -;; Directly analagous to comint-preoutput-filter-functions -(defvar comint-redirect-filter-functions nil - "List of functions to call before inserting redirected process output. -Each function gets one argument, a string containing the text received -from the subprocess. It should return the string to insert, perhaps -the same string that was received, or perhaps a modified or transformed -string. - -The functions on the list are called sequentially, and each one is given -the string returned by the previous one. The string returned by the -last function is the text that is actually inserted in the redirection buffer.") - -(make-variable-buffer-local 'comint-redirect-filter-functions) - -;; Internal variables - -(defvar comint-redirect-output-buffer nil - "The buffer or list of buffers to put output into.") - -(defvar comint-redirect-finished-regexp nil - "Regular expression that determines when to stop redirection in Comint. -When the redirection filter function is given output that matches this regexp, -the output is inserted as usual, and redirection is completed.") - -(defvar comint-redirect-insert-matching-regexp nil - "If non-nil, the text that ends a redirection is included in it. -More precisely, the text that matches `comint-redirect-finished-regexp' -and therefore terminates an output redirection is inserted in the -redirection target buffer, along with the preceding output.") - -(defvar comint-redirect-echo-input nil - "Non-nil means echo input in the process buffer even during redirection.") - -(defvar comint-redirect-completed nil - "Non-nil if redirection has completed in the current buffer.") - -(defvar comint-redirect-original-mode-line-process nil - "Original mode line for redirected process.") - -(defvar comint-redirect-perform-sanity-check t - "If non-nil, check that redirection is likely to complete successfully. -More precisely, before starting a redirection, verify that the -regular expression `comint-redirect-finished-regexp' that controls -when to terminate it actually matches some text already in the process -buffer. The idea is that this regular expression should match a prompt -string, and that there ought to be at least one copy of your prompt string -in the process buffer already.") - -(defvar comint-redirect-original-filter-function nil - "The process filter that was in place when redirection is started. -When redirection is completed, the process filter is restored to -this value.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun comint-redirect-setup (output-buffer - comint-buffer - finished-regexp - &optional echo-input) - "Set up for output redirection. -This function sets local variables that are used by `comint-redirect-filter' -to perform redirection. - -Output from COMINT-BUFFER is redirected to OUTPUT-BUFFER, until something -in the output matches FINISHED-REGEXP. - -If optional argument ECHO-INPUT is non-nil, output is echoed to the -original comint buffer. - -This function is called by `comint-redirect-send-command-to-process', -and does not normally need to be invoked by the end user or programmer." - (with-current-buffer comint-buffer - - (make-local-variable 'comint-redirect-original-mode-line-process) - (setq comint-redirect-original-mode-line-process mode-line-process) - - (make-local-variable 'comint-redirect-output-buffer) - (setq comint-redirect-output-buffer output-buffer) - - (make-local-variable 'comint-redirect-finished-regexp) - (setq comint-redirect-finished-regexp finished-regexp) - - (make-local-variable 'comint-redirect-echo-input) - (setq comint-redirect-echo-input echo-input) - - (make-local-variable 'comint-redirect-completed) - (setq comint-redirect-completed nil) - - (setq mode-line-process - (if mode-line-process - (list (concat (elt mode-line-process 0) " Redirection")) - (list ":%s Redirection"))))) - -(defun comint-redirect-cleanup () - "End a Comint redirection. See `comint-redirect-send-command'." - (interactive) - ;; Restore the process filter - (set-process-filter (get-buffer-process (current-buffer)) - comint-redirect-original-filter-function) - ;; Restore the mode line - (setq mode-line-process comint-redirect-original-mode-line-process) - ;; Set the completed flag - (setq comint-redirect-completed t)) - -;; Because the cleanup happens as a callback, it's not easy to guarantee -;; that it really occurs. -(defalias 'comint-redirect-remove-redirection 'comint-redirect-cleanup) - -(defun comint-redirect-filter (process input-string) - "Filter function which redirects output from PROCESS to a buffer or buffers. -The variable `comint-redirect-output-buffer' says which buffer(s) to -place output in. - -INPUT-STRING is the input from the comint process. - -This function runs as a process filter, and does not need to be invoked by the -end user." - (and process - (with-current-buffer (process-buffer process) - (comint-redirect-preoutput-filter input-string) - ;; If we have to echo output, give it to the original filter function - (and comint-redirect-echo-input - comint-redirect-original-filter-function - (funcall comint-redirect-original-filter-function - process input-string))))) - - -(defun comint-redirect-preoutput-filter (input-string) - "Comint filter function which redirects comint output to a buffer or buffers. -The variable `comint-redirect-output-buffer' says which buffer(s) to -place output in. - -INPUT-STRING is the input from the comint process. - -This function does not need to be invoked by the end user." - (let ((output-buffer-list - (if (listp comint-redirect-output-buffer) - comint-redirect-output-buffer - (list comint-redirect-output-buffer))) - (filtered-input-string input-string)) - - ;; If there are any filter functions, give them a chance to modify the string - (let ((functions comint-redirect-filter-functions)) - (while (and functions filtered-input-string) - (setq filtered-input-string - (funcall (car functions) filtered-input-string)) - (setq functions (cdr functions)))) - - ;; Clobber `comint-redirect-finished-regexp' - (or comint-redirect-insert-matching-regexp - (and (string-match comint-redirect-finished-regexp filtered-input-string) - (setq filtered-input-string - (replace-match "" nil nil filtered-input-string)))) - - ;; Send output to all registered buffers - (save-excursion - (mapcar - (function (lambda(buf) - ;; Set this buffer to the output buffer - (set-buffer (get-buffer-create buf)) - ;; Go to the end of the buffer - (goto-char (point-max)) - ;; Insert the output - (insert filtered-input-string))) - output-buffer-list)) - - ;; Message - (and comint-redirect-verbose - (message "Redirected output to buffer(s) %s" - (mapconcat 'identity output-buffer-list " "))) - - ;; If we see the prompt, tidy up - ;; We'll look for the prompt in the original string, so nobody can - ;; clobber it - (and (string-match comint-redirect-finished-regexp input-string) - (progn - (and comint-redirect-verbose - (message "Redirection completed")) - (comint-redirect-cleanup) - (run-hooks 'comint-redirect-hook))) - ;; Echo input? - (if comint-redirect-echo-input - filtered-input-string - ""))) - -;;;###autoload -(defun comint-redirect-send-command (command output-buffer echo &optional no-display) - "Send COMMAND to process in current buffer, with output to OUTPUT-BUFFER. -With prefix arg, echo output in process buffer. - -If NO-DISPLAY is non-nil, do not show the output buffer." - (interactive "sCommand: \nBOutput Buffer: \nP") - (let ((process (get-buffer-process (current-buffer)))) - (if process - (comint-redirect-send-command-to-process - command output-buffer (current-buffer) echo no-display) - (error "No process for current buffer")))) - -;;;###autoload -(defun comint-redirect-send-command-to-process - (command output-buffer process echo &optional no-display) - "Send COMMAND to PROCESS, with output to OUTPUT-BUFFER. -With prefix arg, echo output in process buffer. - -If NO-DISPLAY is non-nil, do not show the output buffer." - (interactive "sCommand: \nBOutput Buffer: \nbProcess Buffer: \nP") - (let* (;; The process buffer - (process-buffer (if (processp process) - (process-buffer process) - process)) - (proc (get-buffer-process process-buffer))) - ;; Change to the process buffer - (set-buffer process-buffer) - - ;; Make sure there's a prompt in the current process buffer - (and comint-redirect-perform-sanity-check - (save-excursion - (goto-char (point-max)) - (or (re-search-backward comint-prompt-regexp nil t) - (error "No prompt found or `comint-prompt-regexp' not set properly")))) - - ;;;;;;;;;;;;;;;;;;;;; - ;; Set up for redirection - ;;;;;;;;;;;;;;;;;;;;; - (comint-redirect-setup - ;; Output Buffer - output-buffer - ;; Comint Buffer - (current-buffer) - ;; Finished Regexp - comint-prompt-regexp - ;; Echo input - echo) - - ;;;;;;;;;;;;;;;;;;;;; - ;; Set the filter - ;;;;;;;;;;;;;;;;;;;;; - ;; Save the old filter - (setq comint-redirect-original-filter-function - (process-filter proc)) - (set-process-filter proc 'comint-redirect-filter) - - ;;;;;;;;;;;;;;;;;;;;; - ;; Send the command - ;;;;;;;;;;;;;;;;;;;;; - (process-send-string - (current-buffer) - (concat command "\n")) - - ;;;;;;;;;;;;;;;;;;;;; - ;; Show the output - ;;;;;;;;;;;;;;;;;;;;; - (or no-display - (display-buffer - (get-buffer-create - (if (listp output-buffer) - (car output-buffer) - output-buffer)))))) - -;;;###autoload -(defun comint-redirect-results-list (command regexp regexp-group) - "Send COMMAND to current process. -Return a list of expressions in the output which match REGEXP. -REGEXP-GROUP is the regular expression group in REGEXP to use." - (comint-redirect-results-list-from-process - (get-buffer-process (current-buffer)) - command regexp regexp-group)) - -;;;###autoload -(defun comint-redirect-results-list-from-process (process command regexp regexp-group) - "Send COMMAND to PROCESS. -Return a list of expressions in the output which match REGEXP. -REGEXP-GROUP is the regular expression group in REGEXP to use." - (let ((output-buffer " *Comint Redirect Work Buffer*") - results) - (save-excursion - (set-buffer (get-buffer-create output-buffer)) - (erase-buffer) - (comint-redirect-send-command-to-process command - output-buffer process nil t) - ;; Wait for the process to complete - (set-buffer (process-buffer process)) - (while (null comint-redirect-completed) - (accept-process-output nil 1)) - ;; Collect the output - (set-buffer output-buffer) - (goto-char (point-min)) - ;; Skip past the command, if it was echoed - (and (looking-at command) - (forward-line)) - (while (re-search-forward regexp nil t) - (setq results - (cons (buffer-substring-no-properties - (match-beginning regexp-group) - (match-end regexp-group)) - results))) - results))) - -(mapc (lambda (x) - (add-to-list 'debug-ignored-errors x)) - '("^Not at command line$" - "^Empty input ring$" - "^No history$" - "^Not found$" ; Too common? - "^Current buffer has no process$")) - -;; Converting process modes to use comint mode -;; =========================================================================== -;; The code in the Emacs 19 distribution has all been modified to use comint -;; where needed. However, there are `third-party' packages out there that -;; still use the old shell mode. Here's a guide to conversion. -;; -;; Renaming variables -;; Most of the work is renaming variables and functions. These are the common -;; ones: -;; Local variables: -;; last-input-start comint-last-input-start -;; last-input-end comint-last-input-end -;; shell-prompt-pattern comint-prompt-regexp -;; shell-set-directory-error-hook -;; Miscellaneous: -;; shell-set-directory -;; shell-mode-map comint-mode-map -;; Commands: -;; shell-send-input comint-send-input -;; shell-send-eof comint-delchar-or-maybe-eof -;; kill-shell-input comint-kill-input -;; interrupt-shell-subjob comint-interrupt-subjob -;; stop-shell-subjob comint-stop-subjob -;; quit-shell-subjob comint-quit-subjob -;; kill-shell-subjob comint-kill-subjob -;; kill-output-from-shell comint-delete-output -;; show-output-from-shell comint-show-output -;; copy-last-shell-input Use comint-previous-input/comint-next-input -;; -;; SHELL-SET-DIRECTORY is gone, its functionality taken over by -;; SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-filter-functions. -;; Comint mode does not provide functionality equivalent to -;; shell-set-directory-error-hook; it is gone. -;; -;; comint-last-input-start is provided for modes which want to munge -;; the buffer after input is sent, perhaps because the inferior -;; insists on echoing the input. The LAST-INPUT-START variable in -;; the old shell package was used to implement a history mechanism, -;; but you should think twice before using comint-last-input-start -;; for this; the input history ring often does the job better. -;; -;; If you are implementing some process-in-a-buffer mode, called foo-mode, do -;; *not* create the comint-mode local variables in your foo-mode function. -;; This is not modular. Instead, call comint-mode, and let *it* create the -;; necessary comint-specific local variables. Then create the -;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to -;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks -;; (comint-{prompt-regexp, input-filter, input-filter-functions, -;; get-old-input) that need to be different from the defaults. Call -;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; -;; comint-mode will take care of it. The following example, from shell.el, -;; is typical: -;; -;; (defvar shell-mode-map '()) -;; (cond ((not shell-mode-map) -;; (setq shell-mode-map (copy-keymap comint-mode-map)) -;; (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command) -;; (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command) -;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) -;; (define-key shell-mode-map "\M-?" -;; 'comint-dynamic-list-filename-completions))) -;; -;; (defun shell-mode () -;; (interactive) -;; (comint-mode) -;; (setq comint-prompt-regexp shell-prompt-pattern) -;; (setq major-mode 'shell-mode) -;; (setq mode-name "Shell") -;; (use-local-map shell-mode-map) -;; (make-local-variable 'shell-directory-stack) -;; (setq shell-directory-stack nil) -;; (add-hook 'comint-input-filter-functions 'shell-directory-tracker) -;; (run-hooks 'shell-mode-hook)) -;; -;; -;; Completion for comint-mode users -;; -;; For modes that use comint-mode, comint-dynamic-complete-functions is the -;; hook to add completion functions to. Functions on this list should return -;; non-nil if completion occurs (i.e., further completion should not occur). -;; You could use comint-dynamic-simple-complete to do the bulk of the -;; completion job. - -(provide 'comint) - -;;; comint.el ends here rmfile ./site-lisp/guileint-1.5/comint.el hunk ./site-lisp/guileint-1.5/defmenu.el 1 -;;; @(#) defmenu.el -- A GNU Emacs extension which helps building menus -;;; @(#) $Keywords: X, menu $ - -;; Copyright (C) 1995 Mikael Djurfeldt - -;; LCD Archive Entry: -;; defmenu|djurfeldt@nada.kth.se| -;; A GNU Emacs extension which helps building menus| -;; $Date: 1996/10/15 14:58:24 $|$Revision: 1.1 $|~/misc/defmenu.el.Z| - -;; Author: Mikael Djurfeldt -;; Version: 1.0 - -;; This program is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the Free -;; Software Foundation; either version 2 of the License, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU Emacs. If you did not, write to the Free Software Foundation, -;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; Requirements: -;; -;; Usage: -;; -;; Bugs: -;; -;; - -(defun define-menu (keymap key name entries) - "Define a menu in KEYMAP on fake function key KEY with label NAME. -Every entry in the list ENTRIES defines a menu item and looks like this: - - (LABEL DEFINITION [ENABLE-EXP]) - -LABEL is a string which will appear in the menu. -DEFINITION is either a symbol, in which case it will be used both as -fake function key and binding, or a pair, where the car is the fake -function key and the cdr is the binding. -The optional ENABLE-EXP is an expression which will be evaluated every -time the menu is displayed. If it returns nil the menu item will -be disabled. - -You can get a separator by including nil in the ENTRIES list." - (define-key keymap - (vector 'menu-bar key) - (cons name (make-menu name entries)))) - -(defun make-menu (name entries) - "Make a menu with label NAME. -Every entry in the list ENTRIES defines a menu item and looks like this: - - (LABEL DEFINITION [ENABLE-EXP]) - -LABEL is a string which will appear in the menu. -DEFINITION is either a symbol, in which case it will be used both as -fake function key and binding, or a pair, where the car is the fake -function key and the cdr is the binding. -The optional ENABLE-EXP is an expression which will be evaluated every -time the menu is displayed. If it returns nil the menu item will -be disabled. - -You can get a separator by including nil in the ENTRIES list." - (let ((menu (make-sparse-keymap name)) - (entries (reverse entries))) - (while entries - (let ((entry (car entries))) - (if (null entry) - (define-key menu (vector (defmenu-gensym "separator")) '("--")) - (if (symbolp (nth 1 entry)) - (define-key menu (vector (nth 1 entry)) - (cons (car entry) (nth 1 entry))) - (define-key menu (vector (car (nth 1 entry))) - (cons (car entry) (cdr (nth 1 entry))))) - (if (not (null (nthcdr 2 entry))) - (put (nth 1 entry) 'menu-enable (nth 2 entry))))) - (setq entries (cdr entries))) - menu)) - -(defun defmenu-gensym (prefix) - (let ((counter (intern (concat "defmenu-" prefix "count")))) - (if (boundp counter) (set counter (1+ (symbol-value counter))) - (set counter 0)) - (intern (concat prefix (int-to-string (symbol-value counter)))))) - -(provide 'defmenu) rmfile ./site-lisp/guileint-1.5/defmenu.el hunk ./site-lisp/guileint-1.5/fcreate.el 1 -(defun lookup-face-create (face &optional force) - "Get a FACE, or create it if it doesn't exist. In order for it to -properly create the face, the following naming convention must be used: - [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline] - -Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt), -a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\". - -An optional argument, FORCE, will cause the face to be recopied from the -default...which is probably of use only if you've changed fonts." - - ;; make the face if we need to... - (let* ((fn (symbol-name face)) - (frame (selected-frame)) - (basefont (cdr (assq 'font (frame-parameters frame)))) - error fgcolor bgcolor) - (cond - ((or (null face) - ;;(memq face hilit-predefined-face-list) - ) - ;; do nothing if the face is nil or if it's predefined. - ) - ((or force - (not (memq face (face-list))) - (not (string= (get face 'basefont) basefont))) - (copy-face 'default 'scratch-face) - (if (string-match "^reverse-?" fn) - (progn (invert-face 'scratch-face) - (setq fn (substring fn (match-end 0))))) - - ;; parse foreground color - (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) - (setq fgcolor (concat - (if (match-beginning 1) "#") - (substring fn (match-beginning 2) (match-end 2))) - fn (substring fn (match-end 0))) - (error "bad face name %S" face)) - - ;; parse background color - (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn) - (setq bgcolor (concat - (and (match-beginning 1) "#") - (substring fn (match-beginning 2) (match-end 2))) - fn (substring fn (match-end 0)))) - - (and (string= "default" fgcolor) (setq fgcolor nil)) - (and (string= "default" bgcolor) (setq bgcolor nil)) - - ;; catch errors if we can't allocate the color(s) - (condition-case nil - (progn (set-face-foreground 'scratch-face fgcolor) - (set-face-background 'scratch-face bgcolor) - (copy-face 'scratch-face face) - (put face 'basefont basefont)) - (error (message "couldn't allocate color for '%s'" - (symbol-name face)) - (setq face 'default) - (setq error t))) - (or error - ;; don't bother w/ bold or italic if we didn't get the color - ;; we wanted, but ignore errors making the face bold or italic - ;; if the font isn't available, there's nothing to do about it... - (progn - ;(set-face-font face nil frame) MDJ 020919 - (set-face-underline-p face (string-match "underline" fn)) - (if (string-match ".*bold" fn) - ;; make face bold in all frames - (make-face-bold face nil 'noerr)) - (if (string-match ".*italic" fn) - ;; make face italic in all frames - (make-face-italic face nil 'noerr)) - )) - ))) - face) - -(provide 'fcreate) rmfile ./site-lisp/guileint-1.5/fcreate.el hunk ./site-lisp/guileint-1.5/guess-mode.el 1 -;;; @(#) guess-mode.el -- Helps a novice select the right mode -;;; @(#) $Keywords: novice, mode $ - -;; Copyright (C) 1995 Mikael Djurfeldt - -;; LCD Archive Entry: -;; Helps a novice select the right mode|djurfeldt@nada.kth.se| -;; A GNU Emacs extension which | -;; $Date: 1996/11/06 19:51:42 $|$Revision: 1.2 $|~/misc/guess-mode.el.Z| - -;; Author: Mikael Djurfeldt -;; Version: 1.0 - -;; This program is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the Free -;; Software Foundation; either version 2 of the License, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU Emacs. If you did not, write to the Free Software Foundation, -;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; Requirements: -;; -;; Usage: -;; -;; Bugs: -;; -;; - -(defvar guess-mode-load-hook nil - "*Hook run when file is loaded") - -;; Validating the buffer mode... -;; -(defvar gm-check-contents-interval 20) - -(defvar gm-check-contents-maxsize 1000) - -(defvar gm-check-contents-tick-limit 0) -(make-variable-buffer-local 'gm-check-contents-tick-limit) - -(defvar gm-check-modes '(fundamental-mode lisp-interaction-mode)) - -(defvar gm-guess-mode-alist - '(("^(define" . scheme-mode) - ("^#include" . c-mode) - ("^[A-Za-z0-9_]+\\([ \t\n]+[A-Za-z0-9_]+\\)*[ \t\n]+(.*)[ \t\n]+{" . c-mode))) - -(defun gm-check-contents-hook-function () - (if gm-check-contents-tick-limit - (if (> (buffer-modified-tick) - gm-check-contents-tick-limit) - (gm-check-contents)))) - -(if (not (get 'gm-check-contents 'disabled)) - (run-with-idle-timer 2 (function gm-check-contents-hook-function))) - -(defun gm-check-contents () - (interactive) ; This is just to be able to use `disable-command'... - (if (not (memq major-mode gm-check-modes)) - (setq gm-check-contents-tick-limit nil) - (let ((guess (gm-guess-mode))) - (if (not guess) - (if (> (point-max) gm-check-contents-maxsize) - (setq gm-check-contents-tick-limit nil) - (setq gm-check-contents-tick-limit - (+ (buffer-modified-tick) gm-check-contents-interval))) - (if (not (eq guess major-mode)) - (let ((answer nil)) - (while (not answer) - (ding) - (setq answer - (x-popup-dialog - t - (list - (format - "It seems to me like you would like to edit in %s... -Am I right about this?" guess) - '("Yes" . yes) - ;nil - Can't have this due to an emacs bug... - '("No" . nix) - '("No, and never bother me again." . never-again))))) - (if (not (eq answer 'yes)) - (if (eq answer 'never) - (disable-command 'gm-check-contents)) - (funcall guess) - (sit-for 0) - (x-popup-dialog - t - (list - (format - "I have now switched to %s. To make this happen automatically -you should end the filename with %s." guess (gm-make-extension-string guess)) - '("OK" . t)))))) - (setq gm-check-contents-tick-limit nil))))) - -(defun gm-guess-mode () - (let ((alist gm-guess-mode-alist) - (guess nil)) - (save-excursion - (while alist - (goto-char (point-min)) - (if (re-search-forward (car (car alist)) - (+ (point-min) gm-check-contents-maxsize) - t) - (progn - (setq guess (cdr (car alist))) - (setq alist ())) - (setq alist (cdr alist))))) - guess)) - -(defconst gm-extension-regexp-regexp - "\\`\\\\\\(\\.[A-Za-z0-9+]+\\)\\\\\\('\\|\\$\\)\\'") - -(defun gm-make-extension-string (mode) - (let ((alist auto-mode-alist) - (extensions nil)) - (while alist - (if (and (if (consp (cdr (car alist))) - (eq (nth 1 (car alist)) mode) - (eq (cdr (car alist)) mode)) - (string-match gm-extension-regexp-regexp (car (car alist)))) - (setq extensions (cons (concat "\"" - (match-string 1 (car (car alist))) - "\"") - extensions))) - (setq alist (cdr alist))) - (gm-make-enumeration-string extensions "or"))) - -(defun gm-make-enumeration-string (items conjunction) - (let ((n (length items))) - (cond ((= n 1) (car items)) - ((= n 2) (concat (car items) " " conjunction " " (nth 1 items))) - (t - (let ((result (car items))) - (setq items (cdr items)) - (while (cdr items) - (setq result (concat result ", " (car items))) - (setq items (cdr items))) - (concat result " " conjunction " " (car items))))))) - -(provide 'guess-mode) -(run-hooks 'guess-mode-load-hook) rmfile ./site-lisp/guileint-1.5/guess-mode.el hunk ./site-lisp/guileint-1.5/guile-init.el 1 -;;; @(#) guile-init.el -- -;;; @(#) $Keywords: $ - -;; Copyright (C) 1995 Mikael Djurfeldt - -;; LCD Archive Entry: -;; guile-init|djurfeldt@nada.kth.se| -;; A GNU Emacs extension which | -;; $Date: 1997/08/31 21:10:21 $|$Revision: 1.4 $|~/misc/.el.Z| - -;; Author: Mikael Djurfeldt -;; Version: 1.0 - -;; This program is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the Free -;; Software Foundation; either version 2 of the License, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU Emacs. If you did not, write to the Free Software Foundation, -;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; Requirements: -;; -;; Usage: -;; -;; Bugs: -;; -;; - -(defvar guile-init-load-hook nil - "*Hook run when file is loaded") - -(require 'guile) - -;;; Misc. interactivity -;;; -;;; -(defun inda-barf-at-modifications (&rest args) - (or inhibit-read-only - (error "Attempt to modify read-only text"))) - -(defun inda-boldify-previous-character () - ;; Must check this so that we don't point outside buffer... - (if (> (point) (point-min)) - (let ((inhibit-read-only t)) - (put-text-property (1- (point)) (point) 'face 'bold)))) - -(defun inda-make-input-memory (string) - ;; If input consists of many lines, the read-only overlay will - ;; cover the previous line, so we have to disable the protection. - (let ((inhibit-read-only t)) - ;(setq n (1+ n) - ; l (append l (list (list n 'input-filter string)))) - (if (marker-position guile-last-output-end) - (add-text-properties guile-last-output-end (1- (point)) - '(input-memory t rear-nonsticky t mouse-face highlight))))) - -(defun inda-reset-guile-last-output (string) - ;(setq n (1+ n) - ; l (append l (list (list n 'output-filter string)))) - (if (not scheme-ready-p) - (set-marker guile-last-output-end nil))) - -(define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click) -(define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click) - -;; Should rather be implemented with advice. -(defun inda-mouse-yank-at-click (click arg) - "Insert the last stretch of killed text at the position clicked on. -Also move point to one end of the text thus inserted (normally the end). -Prefix arguments are interpreted as with \\[yank]. -If `mouse-yank-at-point' is non-nil, insert at point -regardless of where you click." - (interactive "e\nP") - (if (get-char-property (posn-point (event-start click)) 'input-memory) - (if (memq 'shift (event-modifiers (car click))) - (inda-insert-input-memory click) - (inda-insert-input-memory-and-send click)) - ;; Give temporary modes such as isearch a chance to turn off. - (run-hooks 'mouse-leave-buffer-hook) - (or mouse-yank-at-point (mouse-set-point click)) - (setq this-command 'yank) - (yank arg))) - -(defun inda-insert-input-memory (event) - (interactive "e") - (let* ((pos (posn-point (event-start event))) - (beg (previous-single-property-change (1+ pos) 'mouse-face)) - (end (next-single-property-change pos 'mouse-face))) - (goto-char (point-max)) - (let ((input-start (point))) - (comint-kill-input) - (insert (buffer-substring beg end)) - (add-text-properties input-start (point) - '(mouse-face nil - rear-nonsticky nil - input-memory nil))))) - -(defun inda-insert-input-memory-and-send (event) - (interactive "e") - (inda-insert-input-memory event) - (guile-send-input)) - -(defun inda-boldify (string) - (put-text-property comint-last-input-start (point) 'face 'bold)) - -(defun inda-extend-read-only-overlay (string) - (if guile-input-sent-p - (let ((inhibit-read-only t)) - (move-overlay inda-read-only-overlay (point-min) (point))))) - -;;; Misc. utilities -;;; -(defun scheme-send-buffer () - "Send the current buffer to the inferior Scheme process." - (interactive) - (let (begin end) - (save-excursion - (goto-char (point-max)) - (setq end (point)) - (goto-char (point-min)) - (setq begin (point))) - (scheme-send-region begin end))) - -(defun indent-buffer () - "Indent entire buffer." - (interactive) - (save-excursion - (end-of-buffer) - (let ((end (point))) - (beginning-of-buffer) - (indent-region (point) end nil)))) - -(defun indent-defun () - "Indent lisp definition." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (indent-region (point) end nil)))) - -(provide 'guile-init) -(run-hooks 'guile-init-load-hook) rmfile ./site-lisp/guileint-1.5/guile-init.el hunk ./site-lisp/guileint-1.5/guile.el 1 -;;; @(#) guile.el -- A GNU Emacs interface to Guile -;;; @(#) $Keywords: guile, comint, scheme-mode $ - -;; Copyright (C) 1995, 2002 Mikael Djurfeldt - -;; LCD Archive Entry: -;; guile|djurfeldt@nada.kth.se| -;; A GNU Emacs extension which | -;; $Date: 2002/10/20 09:13:55 $|$Revision: 1.45 $|~/misc/guile.el.Z| - -;; Author: Mikael Djurfeldt -;; Version: 1.5 - -;; This program is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the Free -;; Software Foundation; either version 2 of the License, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU Emacs. If you did not, write to the Free Software Foundation, -;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; Requirements: -;; -;; Usage: -;; -;; Bugs: -;; -;; -;;; ************************************************************************* -;;; * This is code is currently under development * -;;; * Mail any problems to djurfeldt@nada.kth.se * -;;; ************************************************************************* - -(require 'cl) -(require 'fcreate) - -(defvar guile-auto-attach nil) - -(defvar guile-load-hook nil - "*Hook run when file is loaded") - -;;(require 'cmuscheme) -(load "comint") ; `comint' and `cmuscheme' are already loaded. -(load "cmuscheme") ; We need to replace them. - -;; Faces are set in the cond expression below. - -(defvar guile-error-face nil - "Face used to highlight erroneous scheme forms.") - -(defvar guile-backtrace-mouse-face nil - "Face used when the mouse is over a backtrace frame.") - -(defvar guile-modified-face nil - "Face for modified top-level forms in scheme-mode buffers.") - -(defvar guile-broken-face nil - "Face for broken top-level forms in scheme-mode buffers.") - -;; These faces are used during debugging of the list parsing code. - -(defvar guile-unmodified-face-1 nil) -(defvar guile-unmodified-face-2 nil) -(defvar guile-modified-face-1 nil) -(defvar guile-modified-face-2 nil) -(defvar guile-broken-face-1 nil) -(defvar guile-broken-face-2 nil) - -;;; Customization -;;; - -(defvar guile-backtrace-in-source-window t - "*If non-nil, let backtrace windows appear in bottom of source window. -This only occurs if the erring expression can be located.") - -(defvar guile-show-runlight-in-scheme-mode nil - "*If non-nil, show process status also in attached scheme-mode buffers. -Otherwise the mode-line shows if the buffer is attached or not.") - -(defvar guile-default-enhanced-edit t - "If non-nil, automatically enter enhanced edit mode for scheme buffers.") - -(defvar guile-popup-restart-on-death t) - -(defvar guile-popup-restart-on-stop t) - -(defvar guile-insert-reason t) - -(defvar guile-kill-buffer-on-death nil) - -(defvar guile-process-timeout 500 - "Milliseconds") - -(defconst guile-backtrace-buffer-name "*Scheme Backtrace*") - -(defconst guile-error-buffer-name "*Scheme Error*") - -(defconst guile-backtrace-min-height 10) -(defconst guile-backtrace-max-height 30) -(defconst guile-backtrace-min-width 30) -(defconst guile-backtrace-max-width 90) - -(cond ((not window-system) - ;; Faces for text terminals - (setq guile-error-face 'modeline) - (setq guile-backtrace-mouse-face 'highlight) - (setq guile-modified-face nil) ; no special face - (setq guile-broken-face nil) - (setq guile-unmodified-face-1 nil) - (setq guile-unmodified-face-2 'modeline) - (setq guile-modified-face-1 'bold) - (setq guile-modified-face-2 guile-error-face) - (setq guile-broken-face-1 nil) - (setq guile-broken-face-2 nil)) - ((x-display-color-p) - ;; Faces for color screens - (setq guile-error-face (lookup-face-create 'black/red-bold)) - (setq guile-backtrace-mouse-face 'highlight) - (setq guile-modified-face nil) ; no special face - (setq guile-broken-face 'bold) - (setq guile-unmodified-face-1 (lookup-face-create 'black/lightblue)) - (setq guile-unmodified-face-2 'secondary-selection) - (setq guile-modified-face-1 'highlight) - (setq guile-modified-face-2 (lookup-face-create 'black/pink)) - (setq guile-broken-face-1 - (let ((face (make-face 'broken-form-1))) - (copy-face guile-modified-face-1 face) - (set-face-underline-p face t) - face)) - (setq guile-broken-face-2 - (let ((face (make-face 'broken-form-2))) - (copy-face guile-modified-face-2 face) - (set-face-underline-p face t) - face))) - (t - ;; Faces for monochrome screens - (setq guile-error-face (lookup-face-create 'white/black-bold)) - (setq guile-backtrace-mouse-face 'highlight) - (setq guile-modified-face nil) ; no special face - (setq guile-broken-face 'bold) - (setq guile-unmodified-face-1 nil) - (setq guile-unmodified-face-2 'modeline) - (setq guile-modified-face-1 'bold) - (setq guile-modified-face-2 guile-error-face) - (setq guile-broken-face-1 - (let ((face (make-face 'broken-form-1))) - (copy-face guile-modified-face-1 face) - (set-face-underline-p face t) - face)) - (setq guile-broken-face-2 - (let ((face (make-face 'broken-form-2))) - (copy-face guile-modified-face-2 face) - (set-face-underline-p face t) - face)))) - -(if (not (fboundp 'lisp-mode-auto-fill)) - (defun lisp-mode-auto-fill () - (if (> (current-column) (current-fill-column)) - (if (save-excursion - (nth 4 (parse-partial-sexp (save-excursion - (beginning-of-defun) - (point)) - (point)))) - (do-auto-fill) - (let ((comment-start nil) (comment-start-skip nil)) - (do-auto-fill)))))) - -(defconst guile-symclash-obarray-size 521) - -(defconst guile-big-integer 33333333) - -;;; Mode initializers -;;; - -(defvar guile-inferior-scheme-frame nil) - -;; Inferior Scheme Mode -;; -(defun guile-inferior-initialize () - ;; Buffer local variables - (make-local-variable 'guile-eval-result) - (make-local-variable 'guile-eval-output) - (make-local-variable 'guile-last-output-end) - (make-local-variable 'guile-last-prompt-end) - (make-local-variable 'guile-define-name-marker) - (make-local-variable 'guile-unallowed-output) - (make-local-variable 'guile-define-startcol) - (make-local-variable 'guile-define-filler) - (make-local-variable 'guile-define-fillcol) - (set-process-sentinel (scheme-proc) (function guile-sentinel)) - (setq comint-dispatch-alist guile-dispatch-alist) - (add-hook 'comint-input-filter-functions - (function guile-sync-on-input) nil 'local) - (add-hook 'comint-unallowed-output-filter-functions - (function guile-remember-unallowed-output) nil 'local) - (setq comint-dynamic-complete-functions '(guile-complete-symbol)) - (make-local-hook 'scheme-enter-input-wait-hook) - ;; Some initializations - (setq scheme-ready-p nil) - (setq scheme-load-p nil) - (setq guile-no-stack-p nil) - (setq guile-no-source-p nil) - (setq guile-last-output-end (make-marker)) - (setq guile-last-prompt-end (make-marker)) - (setq guile-input-sent-p t) - (setq guile-define-name-marker (make-marker)) - (setq guile-error-p nil) - (setq guile-sexp-overlay nil) - (setq guile-frame-overlay nil) - (let ((enhanced (guile-get-enhanced-buffers))) - (and scheme-buffer (guile-detach-all)) - (for-each (function guile-normal-edit) enhanced) - (guile-kill-overlays) - (for-each (function (lambda (buffer) - (save-excursion - (set-buffer buffer) - (guile-enhanced-edit - buffer - (not scheme-buffer-modified-p))))) - enhanced)) - (setq guile-synchronizedp t) - (setq comint-allow-output-p t) - (setq guile-unallowed-output nil) - ) - -(defvar default-handle-switch-frame-binding - (lookup-key global-map [switch-frame])) -(define-key global-map [switch-frame] 'guile-handle-switch-frame) - -(defun guile-handle-switch-frame (event) - (interactive "e") - (let ((frame (nth 1 event))) - (if (eq frame guile-inferior-scheme-frame) - (guile-sync-with-scheme)) - (funcall default-handle-switch-frame-binding frame))) - -(defun guile-sync-on-input (string) - (if scheme-load-p - (progn - nil)) - (setq guile-error-p nil) ;; What is this??? *fixme* - (guile-sync-with-scheme) - (if guile-error-p - (progn - ;; The read-only-overlay extends during transfer of error and - ;; backtrace information. Check why! *fixme* - (let ((inhibit-read-only t)) - (comint-kill-input)) - ;; By generating an error we interrupt the execution - ;; of the comint-input-filter-functions hook. - (error "Bad expression! Please correct.")))) - -(defvar guile-unallowed-output nil) - -(defun guile-remember-unallowed-output (string) - (if guile-unallowed-output - (setq guile-unallowed-output - (concat guile-unallowed-output string)))) - -(add-hook 'inferior-scheme-mode-hook (function guile-inferior-initialize)) - -;; Scheme Mode -;; -(defvar scheme-buffer-overlays () - "The overlays containing top-level sexps when in enhanced edit mode. -A nil value indicates that the buffer is not in enhanced edit mode.") - -(defvar scheme-buffer-last-overlay nil - "When in enhanced edit mode, this variable contains the lowermost -overlay.") - -(defvar scheme-buffer-modified-p nil - "Non-nil if any overlay has been modified since last synchronization.") - -(defvar scheme-buffer-overlays-modified-p nil) - -(defvar scheme-associated-process-buffer nil - "The buffer of the scheme process to which this buffer is associated. -A value of nil means that this buffer is detached.") - -(defvar scheme-overlay-repair-function nil) - -(make-variable-buffer-local 'scheme-overlay-repair-function) - -(defvar scheme-overlay-repair-idle-timer nil) - -(defun guile-scheme-mode-initialize () - "Initialize a scheme mode buffer." - (make-local-variable 'scheme-buffer-overlays) - (make-local-variable 'scheme-buffer-modified-p) - (make-local-variable 'scheme-buffer-last-overlay) - (make-local-variable 'scheme-buffer-overlays-modified-p) - (make-local-variable 'scheme-associated-process-buffer) - (make-local-variable 'guile-last-broken) - (make-local-variable 'guile-repair-limit) - (make-local-hook 'first-change-hook) - (add-hook 'first-change-hook (function guile-scheme-buffer-modified) nil t) - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook (function guile-scheme-mode-cleanup) nil t) - (if guile-default-enhanced-edit - (guile-enhanced-edit (current-buffer) - ;; If buffer not modified, take a chance... - (and (not scheme-buffer-modified-p) - (not (buffer-modified-p (current-buffer)))) - )) - ) - -(add-hook 'scheme-mode-hook (function guile-scheme-mode-initialize)) - -(defun guile-scheme-buffer-modified () - (setq scheme-buffer-modified-p t)) - -(defun guile-scheme-mode-cleanup () - (if (guile-attachedp (current-buffer)) - (progn - (guile-sync-buffer (current-buffer)) - (guile-detach-buffer (current-buffer)))) - (if (guile-enhancedp (current-buffer)) - (guile-normal-edit (current-buffer)))) - -;;; User interface support -;;; - -(defun guile-clear-transcript () - "Delete all text before the last prompt in the scheme process buffer." - (interactive) - (if (or (not (buffer-name)) - (not (string= (buffer-name) scheme-buffer))) - (error "This command must be issued in the scheme process buffer!")) - (save-excursion - (goto-char (or (marker-position guile-last-prompt-end) - (point-max))) - (if (re-search-backward comint-prompt-regexp nil t) - (goto-char (match-beginning 0)) - (beginning-of-line)) - (let ((inhibit-read-only t)) - (delete-region (point-min) (point))))) - -(defun guile-switch-to-scheme () - "Switch to the scheme process buffer and places cursor at the end. -Also update the scheme process with all changes made in attached buffers." - (interactive) - (guile-sync-with-scheme) - ;(if (not guile-error-p) - ; (switch-to-scheme t)) - (switch-to-scheme t)) - -;;; Process control -;;; -;(defvar scheme-running-p nil -; "This variable, if nil, indicates that the process is waiting for input.") - -(defvar scheme-ready-p nil - "If non-nil, the process is waiting for input at the top-level repl.") - -(defvar scheme-load-p nil) - -(defvar guile-no-stack-p nil) - -(defvar guile-no-source-p nil) - -(defun guile-inferior-dialog (contents) - (let ((window (display-buffer "*scheme*"))) - (x-popup-dialog window contents))) - -(defun guile-sentinel (process reason) - (let ((status (process-status process))) - (if guile-insert-reason - (let ((old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (insert reason) - (goto-char (point-max)) - (sit-for 0)) - (set-buffer old-buffer)))) - (cond ((eq status 'run) - (scheme-set-runlight scheme-last-runlight)) - ((eq status 'stop) - (scheme-set-runlight 'stopped) - (if guile-popup-restart-on-stop - (if (guile-inferior-dialog '("The scheme process has been stopped. -Do you want to restart it?" ("Yes" . t) nil ("No" . nil))) - (continue-process process)))) - (t - (guile-inferior-death-cleanup) - (if guile-popup-restart-on-death - (if (guile-inferior-dialog '("The scheme process has died. -Do you want to restart it?" ("Yes" . t) nil ("No" . nil))) - (run-scheme scheme-program-name) - (or guile-kill-buffer-on-death - (kill-buffer "*scheme*"))) - (or guile-kill-buffer-on-death - (kill-buffer "*scheme*"))))))) - -(defun guile-inferior-death-cleanup () - (scheme-set-runlight nil) - (setq scheme-ready-p nil) - (setq scheme-virtual-file-list nil) - (guile-detach-all)) - -;; It would be too late to set this variable in the inferior-scheme-mode-hook: -;;(setq comint-output-filter-function (function comint-dispatch-output-filter)) -;; *fixme* This should rather be done with advice. - -(defun run-scheme (cmd) - "Run an inferior Scheme process, input and output via buffer *scheme*. -If there is a process already running in *scheme*, just switch to that buffer. -With argument, allows you to edit the command line (default is value -of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook -\(after the comint-mode-hook is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - - (interactive (list (if current-prefix-arg - (read-string "Run Scheme: " scheme-program-name) - scheme-program-name))) - (if (not (comint-check-proc "*scheme*")) - (let ((cmdlist (scheme-args-to-list cmd)) - (comint-output-filter-function - (function comint-dispatch-output-filter))) - (set-buffer (apply 'make-comint "scheme" (car cmdlist) - nil (cdr cmdlist))) - (inferior-scheme-mode))) - (setq scheme-program-name cmd) - (setq scheme-buffer "*scheme*") - (pop-to-buffer "*scheme*") - ;; *fixme* Ugly to specialize `run-scheme' in this way... - (setq guile-inferior-scheme-frame (selected-frame))) - -(defun guile-restart-scheme () - (interactive) - (let ((old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer scheme-buffer) - (let ((attached-buffers inferior-scheme-associated-buffers)) - (guile-shutdown) - (let ((inhibit-read-only t)) - (erase-buffer)) - (setq comint-allow-output-p t) - (run-scheme scheme-program-name) - ;(sit-for 0 200) - (for-each (function (lambda (buffer) - (if (buffer-name buffer) - (guile-attach-buffer buffer)))) - (reverse attached-buffers)))) - (set-buffer old-buffer)))) - -(defun guile-shutdown () - (interactive) - (let ((guile-popup-restart-on-death nil) - (old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer scheme-buffer) - (setq comint-allow-output-p nil) ; Hide output - (setq guile-unallowed-output nil) - (if scheme-ready-p - (let ((inhibit-read-only t)) - (comint-kill-input) - (comint-send-string (scheme-proc) "(quit)\n") - (let ((countdown 5)) - (while (and scheme-ready-p (> countdown 0)) - (sit-for 0 300) - (setq countdown (1- countdown)))))) - (sit-for 0 100) - (if (comint-check-proc "*scheme*") - (progn - (kill-process (scheme-proc)) - (while (comint-check-proc "*scheme*") - (sit-for 0 300)))) - (sit-for 0 100)) - (set-buffer old-buffer)))) - -(defun guile-exit-scheme () - "Stop the running scheme process and kill the corresponding window" - (interactive) - (guile-shutdown) - (if (not (comint-check-proc "*scheme*")) - (kill-buffer "*scheme*"))) - -;;; Basic process protocol - -(setq guile-dispatch-alist - '((?f scheme-exit-input-wait scheme:simple-action) - (?l scheme-load-acknowledge scheme:simple-action) - (?r scheme-enter-read scheme:simple-action) - (?s scheme-enter-input-wait scheme:simple-action) - (?B guile-receive-backtrace scheme:buffer-action) - (?F guile-receive-error scheme:buffer-action) - (?x guile-receive-result scheme:string-action) - (?S guile-no-stack scheme:simple-action) - (?R guile-no-source scheme:simple-action) - )) - -(defun scheme:simple-action (action) - (setq comint-dispatch-state 'idle) - (funcall action)) - -(defun scheme:string-action (action) - (setq comint-string-receiver action) - (setq comint-string-accumulator "") - (setq comint-dispatch-state 'reading-string)) - -(defun scheme:buffer-action (action) - (setq comint-buffer-receiver action) - (setq comint-receiving-buffer (generate-new-buffer "*receiving-buffer*")) - (setq comint-dispatch-state 'reading-to-buffer)) - -;;; Guile protocol - -(defun guile-no-stack () - (setq guile-no-stack-p t)) - -(defun guile-no-source () - (setq guile-no-source-p t)) - -(defvar guile-eval-result nil) -(defvar guile-eval-output nil) - -(defun guile-receive-result (string) - (setq comint-allow-output-p nil) - (setq guile-eval-result string) - (setq guile-eval-output guile-unallowed-output) - (setq guile-unallowed-output nil)) - -(defun guile-eval (sexp &optional stringp) - (let ((process (scheme-proc)) ;*fixme* - (comint-input-filter-functions '()) - (comint-output-filter-functions '())) - (if (not scheme-ready-p) - (error "Scheme process not ready to receive commands.")) - (setq guile-eval-result nil) - (comint-send-string process - (format "(%%%%emacs-eval-request '%S)\n" sexp)) - (while (not guile-eval-result) - (accept-process-output process)) - (while (not scheme-ready-p) - (accept-process-output process)) - (if stringp - guile-eval-result - (car (read-from-string guile-eval-result))))) - -(defun scheme-set-runlight (runlight) - (setq inferior-scheme-mode-line-process - (or runlight "no process")) - (setq scheme-last-runlight runlight) - (if guile-show-runlight-in-scheme-mode - (let ((old-buffer (current-buffer)) - (buffers inferior-scheme-associated-buffers)) - (unwind-protect - (while buffers - (set-buffer (car buffers)) - (setq scheme-mode-line-process runlight) - (setq buffers (cdr buffers))) - (set-buffer old-buffer)))) - (force-mode-line-update t)) - -(defconst scheme-runlight:running "eval" - "The character displayed when the Scheme process is running.") - -(defconst scheme-runlight:input "ready" - "The character displayed when the Scheme process is waiting for input.") - -(defconst scheme-runlight:read "input" - "The character displayed when the Scheme process is waiting for input.") - -(defconst scheme-runlight:load "loading" - "The character displayed when the Scheme process is loading forms.") - -(defvar guile-last-output-end) - -(setq count 0) -(defun scheme-enter-input-wait () - (scheme-set-runlight scheme-runlight:input) - (setq scheme-running-p nil) - (setq scheme-ready-p t) - (setq count (1+ count)) - ;(insert-before-markers (format "#%d\n" count)) - ;(setq n (1+ n) - ; l (append l (list (list n 'enter-input-wait)))) - (if comint-allow-output-p - (progn - (set-marker guile-last-output-end (point)) - (if (and guile-input-sent-p - ;; This code can be invoked multiple times - (or (not (marker-position guile-last-prompt-end)) - (/= (marker-position guile-last-prompt-end) - (point)))) - (progn - (setq guile-input-sent-p nil) - (set-marker guile-last-prompt-end (point)))))) - (setq comint-allow-output-p t) - (run-hooks 'scheme-enter-input-wait-hook)) - -(defun guile-on-error () - (setq guile-input-sent-p t) ;*fixme* - (if comint-allow-output-p - (progn - (goto-char (point-max)) - (if (not (zerop (current-column))) - (insert "\n")) - (set-marker (process-mark (get-buffer-process scheme-buffer)) - (point))))) - -(defun scheme-exit-input-wait () - (scheme-set-runlight scheme-runlight:running) - (setq scheme-ready-p nil) - (setq scheme-running-p t)) - -(defun scheme-enter-read () - (scheme-set-runlight scheme-runlight:read) - (setq scheme-ready-p nil) - (setq scheme-running-p nil)) - -(defun scheme-enter-load () - (scheme-set-runlight scheme-runlight:load) - (setq scheme-ready-p nil) - (setq scheme-load-p t)) - -(defun scheme-load-acknowledge () - (setq scheme-load-p nil)) - -;;; Error reporting and backtrace -;;; -(defvar guile-error-p nil) - -(defvar guile-last-displayed-position nil) - -(defvar guile-positional-reliability nil) - -(defvar guile-last-erring-overlay nil) - -(defvar guile-sexp-overlay nil) - -(defvar guile-frame-overlay nil) - -;(defconst guile-position-regexp -; " at line \\([0-9]+\\), column \\([0-9]+\\) in file \\(.+\\):$") -(defconst guile-position-regexp - "^\\(.+\\):\\([0-9]+\\):\\([0-9]+\\): ") - -(defconst guile-position-regexp-line 2) -(defconst guile-position-regexp-column 3) -(defconst guile-position-regexp-filename 1) - -(defvar guile-error-width 0) -(defvar guile-backtrace-length nil) -(defvar guile-backtrace-width 0) - -(defvar guile-error-map nil) -(if guile-error-map - nil - (setq guile-error-map ;(copy-keymap global-map) copies menus too... - (cons 'keymap (copy-sequence (nth 1 global-map)))) - (suppress-keymap guile-error-map) - (define-key guile-error-map "\e" 'guile-exit-debug) - (define-key guile-error-map "e" 'guile-frame-eval) - (define-key guile-error-map "q" 'guile-exit-debug) - ;; The following line is included since `local-map' doesn't seem to work. - (define-key guile-error-map [mouse-2] 'guile-select-stackframe) - (define-key guile-error-map [S-mouse-2] 'guile-frame-eval-at-click) - ) - -(defvar guile-stack-frame-map nil) -(if guile-stack-frame-map - nil - (setq guile-stack-frame-map (copy-list guile-error-map)) - (fset 'guile-stack-frame-map guile-stack-frame-map) ;*fixme* - (define-key guile-stack-frame-map [mouse-2] 'guile-select-stackframe) - ) - -(setplist 'guile-backtrace-button - (list 'mouse-face guile-backtrace-mouse-face - 'local-map 'guile-stack-frame-map)) - -(defun guile-exit-debug () - (interactive) - (if (eq (selected-frame) guile-error-frame) - (iconify-frame) - (if guile-sexp-overlay - (delete-overlay guile-sexp-overlay)) - (delete-other-windows (frame-first-window))) - (guile-unselect-stackframe)) - -(setq guile-backtrace-received-p nil) ;*fixme* - -(defun guile-receive-backtrace (buffer) - (let ((backtrace (get-buffer-create guile-backtrace-buffer-name))) - (save-excursion - (set-buffer backtrace) - (toggle-read-only 0) - (erase-buffer) - (insert-buffer-substring buffer) - (kill-buffer buffer) - (use-local-map guile-error-map) - (toggle-read-only 1) - (setq truncate-lines t) - (setq guile-backtrace-received-p t)))) ;*fixme* - -(defun guile-prep-backtrace () - (guile-unselect-stackframe) - (let ((buffer (get-buffer-create guile-backtrace-buffer-name))) - (and guile-got-backtrace-p ;*fixme* - (save-excursion - (set-buffer buffer) - (set-syntax-table scheme-mode-syntax-table) - (toggle-read-only 0) - (goto-char (point-max)) - (delete-backward-char 1) - (goto-char (point-min)) - ;; Parse - (save-match-data - (if (not (looking-at "\\(.\\|\n\\)*Backtrace:\n")) - nil - (replace-match "") - (let ((beg (point)) - (width 0) - (len 0)) - (while (not (eobp)) - (forward-line 1) - (let ((o (make-overlay beg (point)))) ;(1- (point)) - (overlay-put o 'category 'guile-backtrace-button) - (overlay-put o 'frame-number-pos beg)) - (setq width (- (point) beg 1)) - (if (> width guile-backtrace-width) - (setq guile-backtrace-width width)) - (setq beg (point)) - (setq len (1+ len))) - (setq guile-backtrace-length len)))) - (toggle-read-only 1))) - buffer)) - -(defvar guile-selected-frame nil) - -(defun guile-select-stackframe (click) - (interactive "e") - (setq guile-no-stack-p nil) - (setq guile-no-source-p nil) - (let* ((frame (save-excursion - (mouse-set-point click) - (goto-char (get-char-property (point) 'frame-number-pos)) - (guile-place-frame-overlay) - (let ((start (point))) - (skip-chars-forward "0-9") - (string-to-number (buffer-substring start (point)))))) - (oldpos (save-excursion - (set-buffer scheme-buffer) - (guile-eval `(%%emacs-select-frame ,frame)))) - (pos (and oldpos (list (nth 0 oldpos) - (1+ (nth 1 oldpos)) ;Increment line number - (nth 2 oldpos))))) - (setq guile-selected-frame frame) - (cond (pos (if guile-source-window ;This is just insane *fixme* - (apply 'guile-display-scheme-sexp - (append pos (list guile-source-window t))) - (guile-display-error (get-buffer guile-error-buffer-name) - (get-buffer guile-backtrace-buffer-name) - pos))) - (guile-no-stack-p (message "No stack.")) - (guile-no-source-p (message "No source."))))) - -(defun guile-unselect-stackframe () - (guile-turn-off-frame-overlay) - (setq guile-selected-frame nil)) - -(defun guile-frame-eval (string) - (interactive "sEval: ") - (if (not guile-selected-frame) - (message "No frame selected.") - (setq guile-no-stack-p nil) - (setq guile-no-source-p nil) - (let ((res (save-excursion - (set-buffer scheme-buffer) - (guile-eval `(%%emacs-frame-eval ,guile-selected-frame - ,string))))) - (cond (guile-no-stack-p (message "No stack.")) - (guile-no-source-p (message "No source.")) - ((eq (car res) 'result) (message "%s = %s" string (cadr res))) - (t (message "%s" (cadr res))))))) - -(defun guile-frame-eval-at-click (click) - (interactive "e") - (save-excursion - (mouse-set-point click) - (forward-sexp) - (let ((end (point))) - (backward-sexp) - (guile-frame-eval (buffer-substring (point) end))))) - -(defun guile-receive-error (buffer) - (guile-on-error) - (setq guile-got-backtrace-p guile-backtrace-received-p) - (setq guile-backtrace-received-p nil) ;*fixme* - (setq guile-error-p t) - (let ((errbuf (get-buffer-create guile-error-buffer-name))) - (save-excursion - (set-buffer errbuf) - (toggle-read-only 0) - (erase-buffer) - (insert-buffer-substring buffer) - (kill-buffer buffer) - (use-local-map guile-error-map) - (toggle-read-only 1) - (setq guile-error-width 0) - (goto-char (point-min)) - (let ((beg (point)) - (width 0)) - (while (not (eobp)) - (forward-line 1) - (setq width (- (point) beg 1)) - (if (> width guile-error-width) - (setq guile-error-width width)) - (setq beg (point)))) - (setq guile-backtrace-width guile-error-width) - (guile-display-error errbuf (guile-prep-backtrace))))) - -(defvar guile-source-window nil) - -(defun guile-display-error (errbuf backbuf &optional pos) - (set-buffer errbuf) - (setq guile-source-window nil) - (let* ((errbuf-len (progn - (goto-char (point-max)) - (1- (guile-current-line)))) - (selected-window (selected-window)) - (mini-window nil) - (window - (if pos - (apply 'guile-display-scheme-sexp pos) - (and (progn - (goto-char (point-min)) - (re-search-forward guile-position-regexp nil t)) - (save-match-data - (guile-display-scheme-sexp - (car (read-from-string - (concat "\"" - (match-string guile-position-regexp-filename) - "\""))) - (string-to-number (match-string guile-position-regexp-line)) - (1- (string-to-number (match-string guile-position-regexp-column)))))))) - (errbuf-lines - (min (+ errbuf-len - (* 2 (/ guile-error-width - (if window - (window-width window) - guile-backtrace-max-width)))) - ;;In case we get big error messages - (/ guile-backtrace-max-height 2))) - (total-height - (if guile-got-backtrace-p - (min (max (+ guile-backtrace-length errbuf-lines 2) - guile-backtrace-min-height) - guile-backtrace-max-height) - (+ errbuf-lines 1)))) - (if (and window guile-backtrace-in-source-window) - (progn - (set-buffer errbuf) ;*fixme* This is awkward... - (or pos - (let ((inhibit-read-only t)) - (replace-match "") - (re-search-forward guile-position-regexp nil t) - (replace-match ""))) - (setq guile-source-window window) ;*fixme* - (and (frame-live-p guile-error-frame) - (make-frame-invisible guile-error-frame)) - (let* ((window-min-height 2) - (size (max (- (window-height window) total-height) - (/ (window-height window) 2))) - (new-window (split-window window size))) - (set-buffer (window-buffer window)) - (goto-char guile-last-displayed-position) - (guile-safe-forward-sexp) - (recenter (/ size 2)) - (setq x errbuf-lines) - (guile-display-buffers errbuf (1+ errbuf-lines) backbuf new-window - pos))) - (setq guile-source-window nil) - (guile-display-buffers - errbuf (1+ errbuf-lines) backbuf - (setq mini-window - (guile-get-create-error-window - total-height - (+ (min (max guile-backtrace-width - guile-backtrace-min-width) - guile-backtrace-max-width) - 2))) - pos)) - (cond ((window-live-p selected-window) - (select-window selected-window)) - ((window-live-p window) - (select-window window)) - ((window-live-p mini-window) - (select-window mini-window))) - ;; Warn if unreliable position - (if (and window (not guile-positional-reliability)) - (message "Warning: Couldn't reliably locate erring expression.")) - )) - -(defun guile-display-buffers (buffer1 split buffer2 window no-ding) - "Display BUFFER1 and BUFFER2 in WINDOW and raise the containing frame. -Display BUFFER1 and BUFFER2 in two windows obtained by splitting WINDOW -and ring the bell. Make sure that the whole contents of BUFFER1 and the -lower part of BUFFER2 will be visible. Also delete all other windows -displaying the buffers." - ;; Delete other windows displaying the buffers - (or (not window-system) (delete-windows-on buffer1)) ; *fixme* - (delete-windows-on buffer2) - ;; Split the window - (let ((lower-window - (and guile-got-backtrace-p - (let ((window-min-height 2) ;; Parameter to split-window - ) - (split-window window split))))) - ;; Contents - (set-window-buffer window buffer1) - (and guile-got-backtrace-p - (set-window-buffer lower-window buffer2)) - ;; Look - (set-window-start window 1) - (if guile-got-backtrace-p - (progn - (let ((pos (save-excursion - (set-buffer buffer2) - (goto-char (point-max)) - (forward-line -1) - (point)))) - (set-window-point lower-window pos)) - (select-window lower-window) - (recenter -1))) - ;; Raise frame - (make-frame-visible (window-frame window)) - (raise-frame (window-frame window)) - ;; Beep - (or no-ding (ding)) - )) - -(defvar guile-error-frame nil) - -(defun guile-get-create-error-window (height width) - (if window-system - (progn - (if (frame-live-p guile-error-frame) - (set-frame-size guile-error-frame width height) - (setq guile-error-frame (make-frame (list (cons 'height height) - (cons 'width width) - '(minibuffer . nil) - '(menu-bar-lines . 0))))) - (let ((window (frame-first-window guile-error-frame))) - (delete-other-windows window) - window)) - (let ((window (get-buffer-window (pop-to-buffer guile-error-buffer-name)))) - (sit-for 0) ; necessary because of an Emacs bug - window))) - -(defun guile-display-scheme-sexp (filename line column &optional swindow no-error-p) - (let ((finfo (scheme-virtual-file-list-find filename))) - (if finfo - (guile-display-sexp finfo line column swindow no-error-p) - (if (stringp filename) - (let ((buffer (guile-get-file-buffer filename))) - (if buffer - (if (and (guile-attachedp buffer) - (not guile-known-by-scheme)) - (progn - ;(ding) ; We shouldn't generate errors inside a filter. - ;(message "Internal data structures corrupt: guile-display-scheme-sexp") - (error "Internal data structures corrupt: guile-display-scheme-sexp")) - (if (and (not scheme-buffer-modified-p) - (not (buffer-modified-p buffer))) - ;; Take a chance and let's hope the file looks - ;; like it did when scheme saw it... - (progn - (if guile-auto-attach - (guile-attach-buffer buffer t) - ;*fixme* - (guile-dont-attach-buffer buffer t)) - (guile-display-scheme-sexp - (guile-buffer-file-name buffer) line column swindow no-error-p)) - nil ; Can't trust this one... - )) - (if (guile-file-readable-p filename) - (let ((guile-known-by-scheme t)) - (let ((buffer (guile-find-file-noselect filename))) - (if guile-auto-attach - (guile-attach-buffer buffer t) - ;*fixme* - (guile-dont-attach-buffer buffer t)) - (guile-display-scheme-sexp - (guile-buffer-file-name buffer) - line column swindow no-error-p))) - (ding) - (message "Couldn't find the erring file.") - nil))))))) - -(defun guile-file-readable-p (filename) - (save-excursion - (set-buffer scheme-buffer) - (file-readable-p filename))) - -(defun guile-find-file-noselect (filename) - (save-excursion - (set-buffer scheme-buffer) - (find-file-noselect filename))) - -(defun guile-display-sexp (finfo line column &optional swindow no-error-p) - ;; Returns the window containing the displayed sexp - (let ((overlay-list (cdr finfo)) - (overlay nil)) - ;; Select an overlay candidate - (while overlay-list - (if (not (overlay-get (car overlay-list) 'original-line)) - (setq overlay-list (cdr overlay-list)) - (if (>= line (overlay-get (car overlay-list) 'original-line)) - (progn - (setq overlay (car overlay-list)) - (setq overlay-list nil)) - (setq overlay-list (cdr overlay-list))))) - (let ((buffer (and overlay (overlay-buffer overlay)))) - (if buffer - (progn - (set-buffer buffer) - (guile-goto-position line column overlay) - (if (< (point) (overlay-end overlay)) - (progn - (setq guile-positional-reliability - (not (overlay-get overlay 'modifiedp))) - (if (not (eq (char-syntax (following-char)) ?\()) - (progn - (setq guile-positional-reliability nil) - (goto-char (overlay-start overlay)))) - (setq guile-last-erring-overlay overlay) - (guile-display-sexp-at-point swindow no-error-p)))))))) - -(defun guile-display-sexp-at-point (&optional swindow no-error-p) - "Move sexp overlay to sexp at point and display window. -Returns the displayed window." - (let ((start (point)) - (end nil)) - (save-excursion - (setq end - (if (guile-safe-forward-sexp) - (point) - (goto-char (1+ start)) - (if (re-search-forward "^\\((\\|$\\)" nil t) - (1- (match-beginning 0)) - (point-max))))) - (if (overlayp guile-sexp-overlay) - (move-overlay guile-sexp-overlay start end (current-buffer)) - (setq guile-sexp-overlay (make-overlay start end)) - (overlay-put guile-sexp-overlay 'category 'guile-error-sexp)) - (if (window-live-p swindow) - (set-window-buffer swindow (current-buffer))) - (guile-display-position start nil swindow no-error-p))) - -(setplist 'guile-error-sexp - (list 'face guile-error-face - 'evaporate t - 'modification-hooks '(guile-turn-off-sexp-overlay) - 'insert-behind-hooks '(guile-turn-off-sexp-overlay))) - -(setplist 'guile-stack-frame - (list 'face guile-error-face - 'mouse-face guile-error-face - 'evaporate t - 'modification-hooks '(guile-turn-off-frame-overlay) - 'insert-behind-hooks '(guile-turn-off-frame-overlay))) - -(defun guile-place-frame-overlay () - (let ((end (save-excursion (forward-line) (point)))) - (if (and guile-frame-overlay (overlayp guile-frame-overlay)) - (move-overlay guile-frame-overlay (point) end) - (setq guile-frame-overlay (make-overlay (point) end))) - (overlay-put guile-frame-overlay 'category 'guile-stack-frame))) - -(defun guile-turn-off-sexp-overlay (&rest args) - (cond (guile-sexp-overlay (delete-overlay guile-sexp-overlay)) - ;; For stability. - ((overlayp (car args)) (delete-overlay (car args))))) - -(defun guile-turn-off-frame-overlay (&rest args) - (cond (guile-frame-overlay (delete-overlay guile-frame-overlay)) - ;; For stability. - ((overlayp (car args)) (delete-overlay (car args))))) - -(defun guile-display-position (pos &optional buffer swindow no-delete-p) - "Display position POS in BUFFER. -If BUFFER is omitted, the current buffer is used. -Returns the displaying window." - (let ((buffer (or buffer (current-buffer)))) - (set-buffer buffer) - (let ((window (or (and (window-live-p swindow) swindow) - (get-buffer-window buffer t) - (if (frame-live-p guile-error-frame) - (delete-frame guile-error-frame)) - (display-buffer buffer)))) - (or no-delete-p - (delete-other-windows window)) - (select-window window) - (goto-char pos) - (setq guile-last-displayed-position pos) - window))) - -(defun guile-goto-position (line column overlay) - (goto-char (overlay-start overlay)) - (forward-line (- line (overlay-get overlay 'original-line))) - (move-to-column column)) - - -;;; Scheme process associated buffers -;;; - -;; This function must be fixed to handle rel/absol filenames -(defun guile-get-file-buffer (filename) - (get-file-buffer filename)) - -(defun guile-attachedp (&optional buffer) - (if buffer - (save-excursion - (set-buffer buffer) - scheme-associated-process-buffer) - scheme-associated-process-buffer)) - -(defun guile-attach-buffer (buffer &optional known-by-scheme) - "Put the buffer in enhanced editing mode and attach it to the scheme -process: load it into scheme, and make sure to send any changes to it -hereafter to scheme at synchronization points." - (interactive (list (current-buffer))) - (if (memq buffer inferior-scheme-associated-buffers) - (error "Scheme buffer already attached!")) - (if (not (guile-enhancedp buffer)) - (guile-enhanced-edit buffer known-by-scheme)) - (save-excursion - (set-buffer scheme-buffer) - (setq inferior-scheme-associated-buffers - (cons buffer - inferior-scheme-associated-buffers)) - (set-buffer buffer) - (setq scheme-associated-process-buffer scheme-buffer) - (if (not guile-show-runlight-in-scheme-mode) - (setq scheme-mode-line-process "attached")) - ;; Now link it to the scheme process - (if (and (guile-buffer-file-name) - (not (guile-virtually-linked-p (guile-buffer-file-name)))) - (guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays)) - ;; And sync. - (if (not known-by-scheme) - (progn - (for-each (function (lambda (overlay) - (overlay-put overlay 'modifiedp t))) - scheme-buffer-overlays) - (setq scheme-buffer-modified-p t) - (setq guile-synchronizedp nil) - (guile-sync-with-scheme)))) - ;; Rebuild menus... - (force-mode-line-update)) - -;;*fixme* -(defun guile-dont-attach-buffer (buffer &optional known-by-scheme) - "Put the buffer in enhanced editing mode and attach it to the scheme -process: load it into scheme, and make sure to send any changes to it -hereafter to scheme at synchronization points." - (interactive (list (current-buffer))) - (if (memq buffer inferior-scheme-associated-buffers) - (error "Scheme buffer already attached!")) - (if (not (guile-enhancedp buffer)) - (guile-enhanced-edit buffer known-by-scheme)) - (save-excursion -; (set-buffer scheme-buffer) -; (setq inferior-scheme-associated-buffers -; (cons buffer -; inferior-scheme-associated-buffers)) - (set-buffer buffer) -; (setq scheme-associated-process-buffer scheme-buffer) == attach -; (if (not guile-show-runlight-in-scheme-mode) -; (setq scheme-mode-line-process "attached")) - ;; Now link it to the scheme process - (if (guile-buffer-file-name) - (guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays)) - ;; And sync. - (if (not known-by-scheme) - (progn - (for-each (function (lambda (overlay) - (overlay-put overlay 'modifiedp t))) - scheme-buffer-overlays) - (setq scheme-buffer-modified-p t) - (setq guile-synchronizedp nil) - ;(guile-sync-with-scheme) - ))) - ;; Rebuild menus... - (force-mode-line-update)) - -(defun guile-detach-buffer (buffer) - "Disconnect the buffer from the scheme process." - (interactive (list (current-buffer))) - (save-excursion - (set-buffer buffer) - ;; Unlink any virtual overlay files associated with the buffer... - ;(let ((overlays scheme-buffer-overlays)) - ; (while overlays - ; (if (guile-virtual-p (car overlays)) - ; (scheme-virtual-unlink (overlay-get (car overlays) 'id))) - ; (setq overlays (cdr overlays)))) - (setq scheme-associated-process-buffer nil) - (if (not guile-show-runlight-in-scheme-mode) - (setq scheme-mode-line-process nil)) - (set-buffer scheme-buffer) - (setq inferior-scheme-associated-buffers - (delq buffer - inferior-scheme-associated-buffers)) - ;(scheme-virtual-unlink (guile-buffer-file-name buffer)) - ) - (force-mode-line-update)) - -(defun guile-detach-all () - "Disconnect all buffers from the scheme process." - (interactive) - (save-excursion - (set-buffer scheme-buffer) - (while inferior-scheme-associated-buffers - ;; Is it alive? - (if (buffer-name (car inferior-scheme-associated-buffers)) - (save-excursion - (set-buffer (car inferior-scheme-associated-buffers)) - (setq scheme-associated-process-buffer nil) - (if (not guile-show-runlight-in-scheme-mode) - (setq scheme-mode-line-process nil)))) - (setq inferior-scheme-associated-buffers - (cdr inferior-scheme-associated-buffers))))) - -;;; Linkage of files to scheme space -;;; -(defvar scheme-virtual-file-list '()) - -(defun scheme-virtual-file-list-find (name) - (let ((name (file-truename name))) - (assoc name scheme-virtual-file-list))) - -(defun guile-buffer-file-name (&optional buffer) - (let ((name (buffer-file-name buffer))) - (and name - (file-truename name)))) - -(defvar guile-synchronizedp t) - -(defvar guile-last-virtual-id 0) - -(defun guile-synchronizedp () - guile-synchronizedp) - -;;*fixme* -(defun guile-alloc-virtual-id (overlay) - (let ((n (setq guile-last-virtual-id (1+ guile-last-virtual-id)))) - (let* ((buffer (overlay-buffer overlay)) - (name (or (guile-buffer-file-name buffer) - (buffer-name buffer)))) - (format "%s(%d)" name n)))) - -(defun guile-virtual-p (overlay) - (overlay-get overlay 'virtualp)) - -(defun guile-virtually-linked-p (name) - (scheme-virtual-file-list-find name)) - -(defun guile-virtual-link (name overlay-list) - (let ((finfo (scheme-virtual-file-list-find name))) - (if finfo - (progn - (guile-kill-overlays (cdr finfo)) - (setcdr finfo (copy-sequence overlay-list))) - (setq scheme-virtual-file-list - (cons (cons name - (copy-sequence overlay-list)) - scheme-virtual-file-list))))) - -(defun scheme-virtual-unlink (name) - (let ((finfo (scheme-virtual-file-list-find name))) - (if finfo - (setq scheme-virtual-file-list - (delq finfo scheme-virtual-file-list))))) - -(defun guile-load-file (filename) - "Load a Scheme file into the inferior Scheme process." - (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file - scheme-source-modes t)) ; T because LOAD - ; needs an exact name - (if (not scheme-ready-p) - (error "Scheme not ready.")) - (comint-check-source filename) ; Check to see if buffer needs to be saved. - (setq scheme-prev-l/c-dir/file (cons (file-name-directory filename) - (file-name-nondirectory filename))) - (let ((old-buffer (current-buffer))) - (set-buffer scheme-buffer) - (setq comint-allow-output-p nil) - (setq guile-unallowed-output nil) - (set-buffer old-buffer)) - (scheme-set-runlight scheme-runlight:load) - (setq scheme-ready-p nil) - (comint-send-string (scheme-proc) (concat "(load \"" - filename - "\"\)\n")) - ;; Syncronize... - (while (not scheme-ready-p) - (accept-process-output (scheme-proc) 0 guile-process-timeout)) - ) - -(defun guile-reread-buffer (buffer) - "Make the scheme interpreter read the buffer contents again." - (interactive (list (current-buffer))) - (if (not scheme-ready-p) - (error "Scheme not ready.")) - (save-excursion - (set-buffer buffer) - (for-each (function (lambda (overlay) - (overlay-put overlay 'modifiedp t))) - scheme-buffer-overlays) - (setq scheme-buffer-modified-p t)) - (setq guile-synchronizedp nil) - (guile-sync-with-scheme)) - -(defun guile-get-associated-buffers () - (save-excursion - (set-buffer scheme-buffer) - inferior-scheme-associated-buffers)) - -(defvar guile-symclash-obarray (make-vector guile-symclash-obarray-size 0)) - -(defun guile-reset-symclash-obarray () - (mapatoms (function makunbound) guile-symclash-obarray)) - -(defvar guile-displayed-erring-buffers nil) -(defvar guile-quiet t) - -(defun guile-check-all () - (interactive) - (setq guile-quiet t) - (guile-check-all-1)) - -(defun guile-check-all-1 () - (guile-show-check-error - (catch 'erroneous-overlay - (guile-reset-symclash-obarray) - (if (not (and guile-last-displayed-erring-overlay - (eq (overlay-buffer guile-last-displayed-erring-overlay) - (current-buffer)))) - (progn - (setq guile-last-displayed-erring-overlay nil) - (setq guile-displayed-erring-buffers nil))) - (for-each (function (lambda (buffer) - (guile-check-buffer-1 buffer) - (setq guile-displayed-erring-buffers - (cons buffer - guile-displayed-erring-buffers)))) - (let ((ls (guile-get-enhanced-buffers)) - (rem guile-displayed-erring-buffers)) - (while rem - (setq ls (delq (car rem) ls)) - (setq rem (cdr rem))) - ls)) - nil))) - -(defun guile-check-buffer (buffer) - (interactive (list (current-buffer))) - (guile-show-check-error - (catch 'erroneous-overlay - (save-excursion - (guile-reset-symclash-obarray) - (guile-check-buffer-1 buffer) - ;(set-buffer old-buffer) - nil)))) - -(defun guile-show-check-error (oinfo) - (if (not oinfo) - (progn - (if guile-last-displayed-erring-overlay - (message "No more errors found among buffers in enhanced editing mode!") - (message "No errors found among buffers in enhanced editing mode!")) - (setq guile-last-displayed-erring-overlay nil) - (setq guile-displayed-erring-buffers nil) - t) - (setq guile-last-displayed-erring-overlay (car oinfo)) - (set-buffer (overlay-buffer (car oinfo))) - (goto-char (overlay-start (car oinfo))) - (if (not guile-quiet) - (ding)) - (guile-display-sexp-at-point) - (recenter) - (message "%s" (cdr oinfo)) - nil)) - -(defvar guile-last-displayed-erring-overlay nil) - -(defun guile-check-buffer-1 (buffer) - (set-buffer buffer) - (save-excursion - (for-each (function guile-check-overlay) - (let* ((ls (reverse scheme-buffer-overlays)) - (tail (memq guile-last-displayed-erring-overlay ls))) - (if tail - (cdr tail) - ls))))) - -(defconst guile-defexpr "(\\(define\\|defmacro\\)[^ \t\n()]*[ \t\n]+(*\\([^ \t\n()]+\\)") -(defconst guile-defexpr-name 2) - -(defun guile-check-overlay (overlay) - (if (overlay-get overlay 'brokenp) - (throw 'erroneous-overlay - (cons overlay "Bad expression.")) - (goto-char (overlay-start overlay)) - (if (looking-at guile-defexpr) - (let ((sym (intern (match-string guile-defexpr-name) - guile-symclash-obarray))) - (if (boundp sym) - (let* ((overlay1 (symbol-value sym)) - (buffer (overlay-buffer overlay1)) - (line (save-excursion - (set-buffer buffer) - (save-excursion - (goto-char (overlay-start overlay1)) - (guile-current-line))))) - (throw 'erroneous-overlay - (cons overlay - (format "Symbol \"%s\" already defined in %s, line %d." - sym - (file-name-nondirectory - (or (guile-buffer-file-name buffer) - (buffer-name buffer))) - line)))) - (set sym overlay)))))) - -(defun guile-sync-with-scheme () - (interactive) - (if (and (not guile-synchronizedp) - scheme-ready-p) - (progn - (setq guile-error-p nil) - (setq guile-last-erring-overlay nil) - (catch 'exit - (for-each (function guile-sync-buffer-1) - (guile-get-associated-buffers)) - (setq guile-synchronizedp t)) - (if guile-last-erring-overlay - (progn - (overlay-put guile-last-erring-overlay 'brokenp t) - (overlay-put guile-last-erring-overlay - 'face guile-broken-face) - (if guile-show-overlays-p - (save-excursion - (set-buffer (overlay-buffer guile-last-erring-overlay)) - (guile-show-overlays)))))))) - -(defun guile-sync-buffer (buffer) - (interactive (list (current-buffer))) - (catch 'exit - (guile-sync-buffer-1 buffer))) - -(defun guile-sync-buffer-1 (buffer) - (save-excursion - (set-buffer buffer) - (if scheme-buffer-modified-p - (progn - ;; Can we do it by loading the file again? - (if (and (not (buffer-modified-p buffer)) - (file-readable-p (guile-buffer-file-name)) - (not (let ((overlays scheme-buffer-overlays)) - (while (and overlays - (not (overlay-get (car overlays) 'brokenp))) - (goto-char (overlay-start (car overlays))) - (overlay-put (car overlays) 'original-line - (guile-current-line)) ; non-optimal *fixme* - (setq overlays (cdr overlays))) - overlays))) - (progn - (guile-load-file (guile-buffer-file-name)) - (if guile-error-p - (progn - (throw 'exit nil))) - (let ((overlays scheme-buffer-overlays)) - (while overlays - (overlay-put (car overlays) 'modifiedp nil) - (setq overlays (cdr overlays))))) - ;; No - we have to send the overlays separately from top to bottom - (let ((overlays (reverse scheme-buffer-overlays))) - (if (or (= (point-min) (point-max)) - (not (eq (char-syntax (char-after (point-min))) ?\())) - (setq overlays (cdr overlays))) - (while overlays - (if (and (overlay-get (car overlays) 'modifiedp) - (not (overlay-get (car overlays) 'brokenp))) - (progn - (guile-send-overlay (guile-alloc-finfo (car overlays))) - (if guile-error-p (throw 'exit nil)))) - (setq overlays (cdr overlays))))) - (setq scheme-buffer-modified-p nil))) - (if guile-show-overlays-p - (guile-show-overlays)))) - -(defun guile-alloc-finfo (overlay) - (if (not (overlay-get overlay 'id)) - (progn - (let ((finfo (scheme-virtual-file-list-find (guile-buffer-file-name)))) - (if finfo - (setcdr finfo (delq overlay (cdr finfo))))) - (guile-new-finfo overlay)) - (let ((finfo (assq (overlay-get overlay 'id) - scheme-virtual-file-list))) - (if finfo - (let ((id (guile-alloc-virtual-id overlay))) - (setcar finfo id) - (overlay-put overlay 'id id) - (overlay-put overlay 'virtualp t) - finfo) - (guile-new-finfo overlay))))) - -(defun guile-new-finfo (overlay) - (let* ((id (guile-alloc-virtual-id overlay)) - (finfo (cons id (list overlay)))) - (overlay-put overlay 'id id) - (overlay-put overlay 'virtualp t) - (goto-char (overlay-start overlay)) - (overlay-put overlay 'original-line (guile-current-line)) - (setq scheme-virtual-file-list - (cons finfo scheme-virtual-file-list)) - finfo)) - -(defvar guile-last-prompt-end nil) -(defvar guile-input-sent-p t) - -(defun guile-send-input () - (interactive) - (if (and (marker-position guile-last-prompt-end) - scheme-ready-p) - (let ((start (save-excursion - (goto-char (point-max)) - (and (guile-real-safe-backward-sexp) - (point))))) - (if (not (and start - (<= (marker-position guile-last-prompt-end) start) - (guile-whitespace-between-p guile-last-prompt-end - start))) - (progn - (insert "\n") - (put-text-property (1- (point)) (point) 'face 'bold)) - (goto-char (point-max)) - (comint-send-input) - (setq guile-input-sent-p t))) - (comint-send-input))) - -(defconst guile-whitespace-chars " \t\n\r\f") - -(defun guile-whitespace-between-p (beg end) - (let ((beg (if (markerp beg) (marker-position beg) beg)) - (end (if (markerp end) (marker-position end) end))) - (if (> beg end) - (let ((swap beg)) - (setq beg end end swap))) - (save-excursion - (goto-char beg) - (skip-chars-forward guile-whitespace-chars end) - (= (point) end)))) - -;;*fixme* This is redundant code. Compare sync. -(defun guile-send-changes () - (interactive) - (setq guile-last-displayed-erring-overlay nil) - (setq guile-displayed-erring-buffers nil) - (setq guile-quiet nil) - (if (guile-check-all-1) - (progn - (setq guile-error-p nil) - (catch 'exit - (let ((old-buffer (current-buffer))) - (for-each (function - (lambda (buffer) - (set-buffer buffer) - (save-excursion - (goto-char (point-max)) - (let ((end (point))) - (beginning-of-buffer) - (guile-send-region (point) end nil t))) - (if guile-show-overlays-p - (guile-show-overlays)))) - (guile-get-enhanced-buffers)) - (set-buffer old-buffer)))))) - -(defun scheme-send-region (start end) - "Send the current region to the inferior Scheme process." - (interactive "r") - (if (not (guile-enhancedp (current-buffer))) - (progn - (comint-send-region (scheme-proc) start end) - (comint-send-string (scheme-proc) "\n")) - (setq guile-error-p nil) - (catch 'exit - (guile-send-region start end t) - (cond (guile-define-header-emitted-p - (message "Defined.")) - (guile-last-result - (guile-insert-before-prompt - (concat "RESULT: " guile-last-result "\n")) - (message "%s" (concat "Result: " guile-last-result))))) - (if guile-show-overlays-p - (guile-show-overlays)))) - -(defvar guile-define-name-marker) - -(defun guile-insert-before-prompt (string) - (save-excursion - (set-buffer scheme-buffer) - (save-excursion - (goto-char guile-last-prompt-end) - (forward-line 0) ;; ignore field boundary - (let ((inhibit-read-only t) - (before-prompt (point)) - (w (or (get-buffer-window scheme-buffer 'visible) - (get-buffer-window scheme-buffer t)))) - (let ((w-start (and w (window-start w)))) - (insert-before-markers string) - (if (and w (= before-prompt w-start)) - (let ((selected (selected-window))) - (unwind-protect - (progn - (select-window w) - (recenter)) - (select-window selected) - (set-buffer scheme-buffer))))))))) - -(defvar guile-define-header-emitted-p nil) -(defvar guile-define-startcol 0) -(defvar guile-define-filler "") -(defvar guile-define-fillcol 0) -(defvar guile-last-result nil) - -(defun guile-send-region (start end send-all-p &optional multip) - (if (not scheme-ready-p) - (error "Scheme is not ready to receive expressions from Emacs.")) - (let ((overlays (reverse scheme-buffer-overlays))) - (if (or (= (point-min) (point-max)) - (not (eq (char-syntax (char-after (point-min))) ?\())) - (setq overlays (cdr overlays))) - ;; First skip some overlays - (while (and overlays (<= (overlay-end (car overlays)) start)) - (setq overlays (cdr overlays))) - (setq guile-define-header-emitted-p nil) - (setq guile-last-result nil) - (let ((start (max start (overlay-start (car overlays))))) - (if (/= start (overlay-start (car overlays))) - (guile-send-overlay (save-excursion - (guile-alloc-finfo (car overlays))) - t - multip - start - end) - (while (and overlays - (< (overlay-start (car overlays)) end)) - (if (and (not (overlay-get (car overlays) 'brokenp)) - (or send-all-p - (overlay-get (car overlays) 'modifiedp))) - (guile-send-overlay (save-excursion - (guile-alloc-finfo (car overlays))) - t - multip)) - (setq overlays (cdr overlays))))))) - -(defconst guile-end-of-chunk "\001\n") - -;; *fixme* Improve code. -(defun guile-send-overlay (finfo &optional interactivep multip start end) - (let* ((filename (car finfo)) - (overlay (car (cdr finfo))) - (module-overlay (overlay-get overlay 'module-overlay)) - (module (or (and module-overlay - (overlay-get module-overlay 'define-module)) - "#f")) - (old-buffer (current-buffer)) - (old-pos (point))) - - ;; Define the module of the overlay if not done before - (if (and module-overlay - (overlay-get module-overlay 'modifiedp)) - (guile-send-overlay (save-excursion - (guile-alloc-finfo module-overlay)))) - - (set-buffer scheme-buffer) - ;; Inhibit process output and hamster it - (setq comint-allow-output-p nil) - (setq guile-eval-output nil) - (setq guile-unallowed-output "") - - (set-buffer old-buffer) - ;; Turn on runlight - (scheme-enter-load) - ;; Send load command - (comint-send-string - (scheme-proc) - (if start - (let ((column (save-excursion - (goto-char start) - (current-column)))) - (format "(%%%%emacs-load %S %d %d '%s #%c)\n" - filename - (+ (overlay-get overlay 'original-line) - -1 - (count-lines (overlay-get overlay 'original-line) - start) - (if (zerop column) 0 -1)) - column - module - (if interactivep ?t ?f))) - (format "(%%%%emacs-load %S %d %d '%s #%c)\n" - filename - (1- (overlay-get overlay 'original-line)) - 0 - module - (if interactivep ?t ?f)))) - ;; Send overlay contents - (comint-send-string - (scheme-proc) - (buffer-substring (or start (overlay-start overlay)) - (or end (overlay-end overlay)))) - ;; If this is the last overlay we may have to send a final newline - ;;(if (and (eq overlay scheme-buffer-last-overlay) - ;; (/= (overlay-start overlay) - ;; (overlay-end overlay)) - ;; (not (eq (char-after (1- (overlay-end overlay))) ?\n))) - (comint-send-string (scheme-proc) "\n") - ;; Remove modified mark so that Emacs will trust its idea about positions. - (or start (overlay-put overlay 'modifiedp nil)) - ;; Send end-of-text - (comint-send-string (scheme-proc) guile-end-of-chunk) - ;; Wait for acknowledge. - (while (and scheme-load-p (not guile-error-p)) - (accept-process-output (scheme-proc) 0 guile-process-timeout)) - - ;; Have we received an error? - (if guile-error-p - (progn - (if interactivep - (save-excursion - (set-buffer scheme-buffer) - (let ((output guile-unallowed-output)) - (if (string-match "\\(^ABORT:.*\n\\)+" output) - (guile-insert-before-prompt (match-string 1 output)))))) - (overlay-put overlay 'modifiedp t) - (setq scheme-load-p nil) - (throw 'exit nil))) ;Abort whatever we was doing. - - ;; The transfer has been successful. Display defined symbol. - (if interactivep - (progn - (goto-char (overlay-start overlay)) - (if (and (not (and start (/= start (overlay-start overlay)))) - (looking-at guile-defexpr)) - (progn - (guile-display-name (match-string guile-defexpr-name) - multip) - (setq guile-last-result nil)) - (set-buffer scheme-buffer) - (if guile-eval-output - (guile-insert-before-prompt guile-eval-output)) - (setq guile-last-result guile-eval-result) - (set-buffer old-buffer)) - (goto-char old-pos) - (sit-for 0)) - - (goto-char old-pos)))) - -(defun guile-display-name (name multip) - (save-excursion - (let ((buffer-file (guile-buffer-file-name)) - (buffer-name (buffer-name))) - (set-buffer scheme-buffer) - (save-excursion - (let ((inhibit-read-only t)) - (if (not guile-define-header-emitted-p) - (let ((header - (format "DEFINED:%s ()\n" - (if multip - (concat " " - (or (and buffer-file - (file-name-nondirectory - buffer-file)) - buffer-name)) - "")))) - (guile-insert-before-prompt header) - (set-marker guile-define-name-marker - (save-excursion - (goto-char guile-last-prompt-end) - (forward-line 0) - (- (point) 2))) - (setq guile-define-startcol (- (length header) 2)) - (setq guile-define-filler - (concat "\n" - (make-string guile-define-startcol ? ))) - (setq guile-define-fillcol - (let ((window (get-buffer-window scheme-buffer t))) - (if window - (- (window-width window) 3) - fill-column))) - (setq guile-define-header-emitted-p t))) - (goto-char guile-define-name-marker) - (cond ((= (current-column) guile-define-startcol)) - ((> (+ (current-column) (length name)) guile-define-fillcol) - (insert-before-markers guile-define-filler)) - (t (insert-before-markers " "))) - (insert-before-markers name)))))) - -;;; Enhanced editing -;;; - -(defvar guile-n-enhanced-buffers 0 - "Number of buffers in enhanced edit mode.") - -(defun guile-enhancedp (&optional buffer) - (interactive) - (if (not buffer) - scheme-buffer-overlays - (save-excursion - (set-buffer buffer) - scheme-buffer-overlays))) - -(defun guile-get-enhanced-buffers () - (let ((ls (buffer-list)) - (ans '())) - (while ls - (if (guile-enhancedp (car ls)) - (setq ans (cons (car ls) ans))) - (setq ls (cdr ls))) - (reverse ans))) - -(defun guile-enhanced-edit (buffer &optional known-by-scheme) - "Put the current scheme buffer into enhanced editing mode." - (interactive (list (current-buffer))) - (if (guile-enhancedp buffer) - (error "Already in enhanced editing mode!")) - (save-excursion - (set-buffer buffer) - (guile-parse-buffer known-by-scheme) - (setq scheme-overlay-repair-function 'guile-repair-overlays) - (if (not (memq scheme-overlay-repair-idle-timer timer-idle-list)) - (setq scheme-overlay-repair-idle-timer - (run-with-idle-timer 0.1 t 'run-hook-with-args - 'scheme-overlay-repair-function))) - (setq guile-n-enhanced-buffers (1+ guile-n-enhanced-buffers))) - (force-mode-line-update)) - -(defun guile-normal-edit (buffer) - "Exit enhanced editing mode." - (interactive (list (current-buffer))) - (if (guile-attachedp) - (error "Can't exit enhanced editing mode while attached to scheme. Detach first.")) - (save-excursion - (set-buffer buffer) - (for-each (function (lambda (overlay) - (if (overlayp overlay) ; For stability's sake - (progn - (if (guile-virtual-p overlay) - (scheme-virtual-unlink (overlay-get overlay 'id))) - (delete-overlay overlay))))) - scheme-buffer-overlays) - (setq scheme-buffer-overlays ()) - (setq scheme-buffer-last-overlay nil) - ;; Since we let go of the control, we have to mark the buffer... - ;(setq scheme-buffer-modified-p t) Now using first-change-hook. - (setq scheme-overlay-repair-function nil) - (scheme-virtual-unlink (guile-buffer-file-name buffer)) - (setq guile-n-enhanced-buffers (1- guile-n-enhanced-buffers))) - (force-mode-line-update)) - -;;; Overlay lists -;;; -;;; Every non-broken overlay containing a sexp starts with a character -;;; with syntax ?\(. -;;; The first overlay in the overlay list is never broken. - -(defun guile-current-line () - (+ (count-lines 1 (point)) - (if (= (current-column) 0) 1 0))) - -(defun guile-safe-forward-sexp () - "Move point one sexp forwards. -Returns non-nil if no error was encountered." - (not (condition-case err - (forward-sexp) - (error err)))) - -(defun guile-safe-backward-sexp () - "Move point one sexp forwards. -Returns non-nil if no error was encountered." - (not (condition-case err - (backward-sexp) - (error err)))) - -(defun guile-real-safe-backward-sexp () - (and (guile-safe-backward-sexp) - (progn - (and (char-before) - (char-before (1- (point))) - (eq (char-before (1- (point))) ?#) - (eq (char-syntax (char-before)) ?w) - (forward-char -2)) - t))) - -(defun guile-parse-buffer (&optional initialp) - (interactive) - (if (= (point-min) (point-max)) - ;; Apparently, the buffer is empty - (progn - (setq overlay (make-overlay (point-min) (point-max) nil nil t)) - (overlay-put overlay 'modification-hooks - '(guile-handle-modification)) - (overlay-put overlay 'insert-behind-hooks - '(rear-sticky-overlay-function guile-handle-modification)) - (setq scheme-buffer-overlays (list overlay)) - (setq scheme-buffer-last-overlay overlay)) - (setq scheme-buffer-last-overlay nil) - (guile-reparse-buffer nil (point-min) initialp) - (guile-modularize scheme-buffer-overlays))) - -(defvar guile-tail-cons (cons nil nil)) - -(defun guile-cons-before-match (x ls) - "Match X against successive elements of LS. -Return cons before the one with car matching X." - (if (or (null ls) - (eq (car ls) x)) - nil - (while (and (cdr ls) (not (eq (car (cdr ls)) x))) - (setq ls (cdr ls))) - (and (cdr ls) - ls))) - -;; Here I've sacrificed readability for speed... -;; Geeh! What a monstrum! -;; -(defun guile-reparse-buffer (start-overlay limit &optional initialp) - "Reparse buffer backwards to build/update `scheme-buffer-overlays'. -Start with overlay START-OVERLAY. Stop when we have passed LIMIT. -If START-OVERLAY is nil parsing starts from (point-max). -The optional third argument INITIALP should be non-nil if parsing -for the first time. This will cause initialization of the -original-line property." - (let* ((tailp (and start-overlay - (progn - (goto-char (overlay-end start-overlay)) - (if (bolp) - (guile-cons-before-match start-overlay - scheme-buffer-overlays) - (let ((after (guile-cons-before-match - start-overlay - scheme-buffer-overlays))) - (if after - (progn - (overlay-put (car after) 'brokenp t) - (guile-cons-before-match - after - scheme-buffer-overlays)))))))) - (tail (or tailp guile-tail-cons)) - (overlays (if tailp (cdr tail) scheme-buffer-overlays)) - (overlay nil) - (first-broken nil) - (last-broken nil) - (last-end (if tailp - (overlay-end (car (cdr tail))) - (point-max)))) - (goto-char last-end) - ;; Parse buffer backwards... - (save-match-data - (while (> (point) limit) - ;; First try to move one sexp backwards... - (if (and (guile-safe-backward-sexp) - (bolp)) - (progn - ;; Do we have it in the list? - (while (and overlays - (> (overlay-start (car overlays)) (point))) - ;; First throw away some trash overlays... - (let ((id (overlay-get (car overlays) 'id))) - (delete-overlay (car overlays)) - (if id - ;; It's a stand-alone sexp, remove it from the list - (scheme-virtual-unlink id))) - (setq overlays (cdr overlays))) - (if (and overlays - (= (overlay-start (car overlays)) (point))) - ;; Yes! - (progn ; Is it intact? - (if (or (overlay-get (car overlays) 'brokenp) - (/= (overlay-end (car overlays)) last-end)) - ;; No... - (progn - ;; Adjust it. - (move-overlay (car overlays) (point) last-end) - ;; Can we repair it? - (if (if (bobp) - (or (eolp) - (eq (char-syntax (following-char)) ?\() - (eq (char-syntax (following-char)) ?<) - (eq (char-syntax (following-char)) ? )) - (eq (char-syntax (following-char)) ?\()) - ;; Yes! - (progn - (overlay-put (car overlays) 'brokenp nil) - (overlay-put (car overlays) 'face nil) - (overlay-put (car overlays) 'modifiedp t) - (overlay-put (car overlays) - 'define-module - (and (looking-at "(define-module \\((.*)\\)") - (condition-case err - (save-excursion - (goto-char (match-beginning 1)) - (read (current-buffer))) - (error nil))))) - ;; No... - (overlay-put (car overlays) 'face guile-broken-face) - (overlay-put (car overlays) 'modifiedp t)))) - ;; Link it in. - (setcdr tail overlays) - (setq tail (cdr tail)) - (setq overlays (cdr overlays))) - ;; We probably have to make a new overlay... - ;; First check if it's OK. - (if (if (bobp) - (or (eolp) - (eq (char-syntax (following-char)) ?\() - (eq (char-syntax (following-char)) ?<) - (eq (char-syntax (following-char)) ? )) - (eq (char-syntax (following-char)) ?\()) - ;; Everything seems OK with this one. - (progn - (setq overlay (make-overlay (point) last-end nil nil t)) - (if initialp - (overlay-put overlay 'original-line - (guile-current-line)) - (overlay-put overlay 'modifiedp t)) - (overlay-put overlay 'modification-hooks - '(guile-handle-modification)) - (overlay-put overlay - 'define-module - (and (looking-at "(define-module \\((.*)\\)") - (condition-case err - (save-excursion - (goto-char (match-beginning 1)) - (read (current-buffer))) - (error nil)))) - ;; And link it in... - (setcdr tail (cons overlay overlays)) - (setq tail (cdr tail))) - ;; But this one is broken! - ;; Try to find some structure... - (guile-backward-broken-sexp) - (while (and overlays - (> (overlay-start (car overlays)) (point))) - (let ((id (overlay-get (car overlays) 'id))) - (delete-overlay (car overlays)) - (if id - (scheme-virtual-unlink id))) - (setq overlays (cdr overlays))) - ;; Is it possibly the first one in the overlay list? - (if (and overlays - (= (overlay-start (car overlays)) (point))) - (progn - ;; Adjust it. - (move-overlay (car overlays) (point) last-end) - (overlay-put (car overlays) 'face guile-broken-face) - (overlay-put (car overlays) 'modifiedp t) - ;; Link it in. - (setcdr tail overlays) - (setq tail (cdr tail)) - (setq overlays (cdr overlays))) - ;; It wasn't - make a new overlay. - (setq overlay (make-overlay (point) last-end nil nil t)) - (overlay-put overlay 'brokenp t) - (overlay-put overlay 'face guile-broken-face) - (overlay-put overlay 'modification-hooks - '(guile-handle-modification)) - ;; And link it in... - (setcdr tail (cons overlay overlays)) - (setq tail (cdr tail)))))) - ;; Broken overlay... Here we go again! - (guile-backward-broken-sexp) - (while (and overlays - (> (overlay-start (car overlays)) (point))) - (let ((id (overlay-get (car overlays) 'id))) - (delete-overlay (car overlays)) - (if id - (scheme-virtual-unlink id))) - (setq overlays (cdr overlays))) - (if (and overlays - (= (overlay-start (car overlays)) (point))) - (progn - (setq overlay (car overlays)) - (move-overlay overlay (point) last-end) - (setcdr tail overlays) - (setq tail (cdr tail)) - (setq overlays (cdr overlays))) - (setq overlay (make-overlay (point) last-end nil nil t)) - (overlay-put overlay 'modification-hooks - '(guile-handle-modification)) - (setcdr tail (cons overlay overlays)) - (setq tail (cdr tail))) - (overlay-put overlay 'brokenp t) - (overlay-put overlay 'face guile-broken-face)) - (if (overlay-get (car tail) 'brokenp) - (progn - (setq first-broken (car tail)) - (if (not last-broken) - (setq last-broken (car tail))))) - (setq last-end (point)))) - (if (not tailp) - (progn - (setq scheme-buffer-overlays - (cdr guile-tail-cons)) - ;; Don't let the rear-stickiness propagate upwards... - (if scheme-buffer-last-overlay - (if (not (eq (car scheme-buffer-overlays) - scheme-buffer-last-overlay)) - (progn - (overlay-put scheme-buffer-last-overlay - 'insert-behind-hooks - nil) - (overlay-put (car scheme-buffer-overlays) - 'insert-behind-hooks - '(rear-sticky-overlay-function - guile-handle-modification)))) - (overlay-put (car scheme-buffer-overlays) - 'insert-behind-hooks - '(rear-sticky-overlay-function guile-handle-modification))) - (setq scheme-buffer-last-overlay - (car scheme-buffer-overlays)))) - (setq guile-last-broken last-broken) - (setq guile-repair-limit - (if first-broken - ;(overlay-start - ; (let ((ovls (memq first-broken scheme-buffer-overlays))) - ; (or (and ovls (cdr ovls) (car (cdr ovls))) - ; first-broken) - (overlay-start first-broken) - guile-big-integer))) - (if guile-show-overlays-p - (guile-show-overlays)) - ) - -(defvar guile-last-broken nil) -(defvar guile-repair-limit guile-big-integer) - -(defun guile-handle-modification (overlay after from to &optional length) - (if after - (progn - (overlay-put overlay 'brokenp t) - (setq scheme-buffer-overlays-modified-p t) - (if guile-last-broken - (if (< (overlay-start overlay) guile-repair-limit) - (setq guile-repair-limit - ;(overlay-start - ; (let ((ovls (memq overlay scheme-buffer-overlays))) - ; (or (and ovls (cdr ovls) (car (cdr ovls))) - ; overlay))) - (overlay-start overlay)) - (if (> (overlay-start overlay) - (overlay-start guile-last-broken)) - (setq guile-last-broken overlay))) - (setq guile-last-broken overlay) - (setq guile-repair-limit - ;(overlay-start - ; (let ((ovls (memq overlay scheme-buffer-overlays))) - ; (or (and ovls (cdr ovls) (car (cdr ovls))) - ; overlay))) - (overlay-start overlay)))))) - -(defun guile-repair-overlays () - (if (and (eq major-mode 'scheme-mode) - scheme-buffer-overlays-modified-p) - (save-excursion - ;(ding) - ;(message "Repair!") - (setq scheme-buffer-modified-p t) - (if scheme-associated-process-buffer - (setq guile-synchronizedp nil)) - (guile-reparse-buffer guile-last-broken guile-repair-limit) - (guile-modularize scheme-buffer-overlays) - (setq scheme-buffer-overlays-modified-p nil)))) - -(defun guile-modularize (r-overlays) - (let ((overlays (reverse r-overlays)) - (module nil)) - (while overlays - (if (overlay-get (car overlays) 'define-module) - (progn - (overlay-put (car overlays) 'module-overlay nil) - (setq module (car overlays))) - (overlay-put (car overlays) 'module-overlay module)) - (setq overlays (cdr overlays))))) - -(defun guile-backward-broken-sexp () - (interactive) - (beginning-of-line) - (let ((last (point))) - (while (not (or (bobp) - (and (eq (following-char) ?\() - (guile-safe-backward-sexp) - (bolp)))) - (forward-line -1) - (beginning-of-line) - (setq last (point))) - (let ((end (point))) - (goto-char (if (guile-safe-forward-sexp) - last - end))))) - -;; rear-sticky-overlay-function: -;; Put this function in the `insert-behind-hooks' of an overlay -;; in order to make the overlay rear-sticky. - -(defun rear-sticky-overlay-function (overlay after from to &optional length) - (if after - (move-overlay overlay (overlay-start overlay) to))) - -;;; Some debugging utilities -;;; - -(defvar guile-show-overlays-p nil) - -(defun guile-show-overlays () - (interactive) - (if (guile-enhancedp) - (let ((n 1) - (color nil) - (previous nil) - (overlays scheme-buffer-overlays)) - (if (null overlays) - (progn - (ding) - (message "Empty overlay list!")) - (if (not (memq 'rear-sticky-overlay-function - (overlay-get (car overlays) 'insert-behind-hooks))) - (progn - (ding) - (message "Last overlay not rear-sticky!"))) - (while overlays - (overlay-put (car overlays) - 'face - (if (setq color (not color)) - (if (overlay-get (car overlays) 'brokenp) - guile-broken-face-1 - (if (overlay-get (car overlays) 'modifiedp) - guile-modified-face-1 - guile-unmodified-face-1)) - (if (overlay-get (car overlays) 'brokenp) - guile-broken-face-2 - (if (overlay-get (car overlays) 'modifiedp) - guile-modified-face-2 - guile-unmodified-face-2)))) - (if previous - (progn - (if (/= (overlay-end (car overlays)) - (overlay-start previous)) - (progn (ding) - (message "Bad end boundary at overlay no. %d" n))) - (if (overlay-get (car overlays) 'insert-behind-hooks) - (progn - (ding) - (message "Inner overlay no. %d rear-sticky!" n))))) - (setq previous (car overlays)) - (setq n (1+ n)) - (setq overlays (cdr overlays))) - (if (/= (overlay-start previous) (point-min)) - (progn - (ding) - (message "First overlay doesn't start at %d" (point-min))))))) - (setq guile-show-overlays-p t)) - -(defun guile-hide-overlays () - (interactive) - (let ((color nil) - (overlays scheme-buffer-overlays)) - (while overlays - (overlay-put (car overlays) - 'face - (if (overlay-get (car overlays) 'brokenp) - guile-broken-face - nil)) - (setq overlays (cdr overlays)))) - (setq guile-show-overlays-p nil)) - -;; *fixme* Consider removing this function -(defun guile-kill-overlays (&optional ls) - (interactive) - (if (not ls) - (progn - (setq ls (apply (function append) - (mapcar (function cdr) - scheme-virtual-file-list))) - (setq scheme-virtual-file-list ()))) - (while ls - (delete-overlay (car ls)) - (setq ls (cdr ls)))) - -;; *fixme* Consider removing this function -(defun overlay-kill () - (interactive) - (delete-overlay (car (overlays-at (point))))) - -(defun for-each (func ls) - (while ls - (funcall func (car ls)) - (setq ls (cdr ls)))) - - -;;; Completion - -(defconst guile-symbol-chars "---A-ZÅÄÖa-zåäö0-9!$%&/=?@+*<>|-_:.") - -(defun guile-match-symnames (word &optional exactp) - (if (not word) - '() - (save-excursion - (set-buffer scheme-buffer) - (guile-eval `(map symbol->string - (%%apropos-internal - ,(concat "^" - (regexp-quote word) - (and exactp "$")))))))) - -(defmacro guile-force-splittable (&rest forms) - `(let ((f (selected-frame)) - (w (selected-window))) - (let ((unsplittable (assq 'unsplittable (frame-parameters f))) - (dedicatedp (window-dedicated-p w)) - (same-window-buffer-names - (append same-window-buffer-names - (list (buffer-name (window-buffer w)))))) - (unwind-protect - (progn - (modify-frame-parameters f '((unsplittable . nil))) - (set-window-dedicated-p w nil) - ,@forms) - (modify-frame-parameters f (list unsplittable)) - (set-window-dedicated-p w dedicatedp))))) - -(defvar guile-complete-function 'comint-dynamic-complete) - -(defun guile-indent-or-complete () - (interactive) - (let ((beg (save-excursion - (beginning-of-line) - (point)))) - (if (guile-whitespace-between-p beg (point)) - (funcall 'indent-for-tab-command) - (funcall guile-complete-function)))) - -(defun guile-complete-symbol () - (interactive) - (let ((word (comint-word guile-symbol-chars))) - (if word - (progn - (guile-force-splittable - (comint-dynamic-simple-complete word (guile-match-symnames word))) - (if (string= (buffer-name) scheme-buffer) - (put-text-property comint-last-output-start - (point) 'face 'bold)))))) - -(defun guile-list-completions () - (interactive) - (let* ((word (comint-word guile-symbol-chars)) - (candidates (mapcar (function (lambda (x) (list x))) - (guile-match-symnames word))) - (completions (all-completions word candidates))) - (if (null completions) - (message "No completions of %s" word) - (guile-force-splittable - (comint-dynamic-list-completions completions)) - (if (string= (buffer-name) scheme-buffer) - (put-text-property comint-last-output-start (point) 'face 'bold))))) - -;;; Documentation - -(defun guile-documentation-symbols () - (save-excursion - (set-buffer scheme-buffer) - (guile-eval '(map symbol->string (%%apropos-internal ""))))) - -(defun guile-variable-at-point (symnames) - (condition-case () - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table scheme-mode-syntax-table) - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (following-char)) ?w) - (eq (char-syntax (following-char)) ?_) - (forward-sexp -1)) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (member (symbol-name obj) symnames) obj))) - (set-syntax-table stab))) - (error nil))) - -(defun guile-describe-variable (variable) - "Display the full documentation of Guile variable VARIABLE." - (interactive - (let ((symnames (guile-documentation-symbols))) - (let ((symbol (guile-variable-at-point symnames)) - (enable-recursive-minibuffers t) - val) - (setq val (completing-read (if symbol - (format "Describe Guile variable (default %s): " symbol) - "Describe Guile variable: ") - (mapcar (lambda (s) - (cons s '())) - symnames) - nil t)) - (list (if (equal val "") - symbol - (intern val)))))) - (guile-force-splittable - (with-output-to-temp-buffer "*Help*" - (prin1 variable) - (princ ": ") - (princ (save-excursion - (set-buffer scheme-buffer) - (guile-eval variable t))) - (terpri) - (terpri) - (let ((doc (save-excursion - (set-buffer scheme-buffer) - (guile-eval `(%%emacs-symdoc ',variable))))) - (if doc - (princ doc) - (princ "not documented"))) - (print-help-return-message) - (save-excursion - (set-buffer standard-output) - (help-mode) - ;; Return the text we displayed. - (buffer-string))))) - -(provide 'guile) -(run-hooks 'guile-load-hook) rmfile ./site-lisp/guileint-1.5/guile.el hunk ./site-lisp/guileint-1.5/guileint.el 1 -;;; NAME: guileint.el -;;; SYNOPSIS: A Guile/Emacs interface prototype -;;; VERSION: 1.5 -;;; LAST CHANGE: 2002-10-19 -;;; CREATED: 1997-07-17 -;;; AUTHOR: Mikael Djurfeldt -;;; COPYRIGHT: (C) 1997, 2002 Mikael Djurfeldt -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. -;;; -;;; REQUIREMENTS: -;;; -;;; USAGE: -;;; -;;; BUGS: -;;; -;;; -;;; Setup load-path - -(if (featurep 'guileint) - nil - -(require 'cl-19 "cl") - -(defconst guileint-init-file "guileint") - -(defvar guileint-emacs-dir nil) -(let ((pathlist (getenv "EMACSSITELOAD"))) - (if (and pathlist - (string-match (concat "\\(\\(/[^:/]+\\)*\\)/?" - guileint-init-file - "\\(\.elc?\\)?\\(:\\|\\'\\)") - pathlist)) - (setq guileint-emacs-dir (match-string 1 pathlist)))) - -(defvar guileint-default-load-path load-path) -(setq load-path - (append (list - guileint-emacs-dir - ) - guileint-default-load-path - '( - ))) - -(setq scheme-program-name - (let ((v (getenv "SCHEME_PROGRAM_NAME"))) - (or v - (concat "guile" - (and window-system " --emacs"))))) - -;;; Select buffers to pop up as separate windows -(if window-system - (progn - (defvar default-special-display-buffer-names - special-display-buffer-names) - (setq special-display-buffer-names - (union default-special-display-buffer-names '("*scheme*"))) - - (setq same-window-buffer-names - (delete "*scheme*" same-window-buffer-names)) - - (setq special-display-frame-alist - '((height . 24) (width . 80) (unsplittable . t))) - )) - -;;; Do things to support lisp-hacking better -(if (equal (substring emacs-version 0 2) "19") - ;; Emacs version 19 specific initializations - (progn - (copy-face 'default 'paren) - (condition-case err - (make-face-bold 'paren) - (error)) - (setq show-paren-face 'paren) - (require 'paren) - ;; The old parenthesis matcher has the advantage of displaying - ;; non-visible matching parenthesis in the minibuffer. - ;; Since paren.el adds (setq blink-paren-function nil) to the - ;; window-setup-hook it's necessary to put this setq there - ;; also. - (add-hook 'window-setup-hook (function restore-blink-paren) t) - (setq blink-matching-delay 0.5) - )) - -(defun restore-blink-paren () - (interactive) - (setq blink-matching-paren-on-screen t) - (set-face-underline-p 'paren t)) - -;;; Menus -;;; - -(require 'defmenu) - -;(setq menu-bar-final-items -; '(completion inout signals scheme help-menu)) -(setq menu-bar-final-items - '(interpret scheme help-menu)) - -;; The global menu -;; -(define-menu global-map 'interpret "Interpret" - '(("Guile" run-scheme (not (comint-check-proc "*scheme*"))) - ("Switch to *scheme*" guile-switch-to-scheme - (comint-check-proc "*scheme*")))) - -(load "inda-scheme") - -(provide 'guileint) -) rmfile ./site-lisp/guileint-1.5/guileint.el hunk ./site-lisp/guileint-1.5/hilit-scheme.el 1 -(if (not (fboundp 'hilit-extend-face-translation-table)) - (defun hilit-extend-face-translation-table (face-table) - (let ((index (or (and (x-display-color-p) - (cdr (assq hilit-background-mode - '((light . 1) (dark . 2))))) - 3))) - (mapcar (function - (lambda (x) - (let ((entry (assq (car x) hilit-face-translation-table))) - (if entry - (setcdr entry (nth index x)) - (setq hilit-face-translation-table - (cons (cons (car x) (nth index x)) - hilit-face-translation-table)))))) - face-table))) -) hunk ./site-lisp/guileint-1.5/hilit-scheme.el 2 -(hilit-extend-face-translation-table - '((predicate violetred purple nil) - (mutator red red nil))) - -(hilit-set-mode-patterns - '(scheme-mode inferior-scheme-mode) - '((";.*" nil comment) - (hilit-string-find ?\\ string) - ("^\\s *(define\\(-syntax\\|-class\\)?\\([ \t]*[\n]?[ \t]*\\(([^()]*)\\|[^ \t\n()]+\\)\\)?" () defun) - ("^\\s *(\\(provide\\|require\\|load\\).*$" nil include) - ("\\s *\\&\\(rest\\|optional\\)\\s *" nil decl) ; keyword - ("(\\(else\\|unquote\\(-splicing\\)?\\|quote\\|lambda\\|lambda\\*\\|if\\|begin\\|cond\\|and\\|or\\|case\\|let\\*?\\|letrec\\|do\\|delay\\|quasiquote\\)[ \t\n]" 1 decl) ; keyword - ("(\\([^ \t\n(]+\\?\\)" 1 predicate) - ("(\\([^ \t\n(]+!\\)" 1 mutator) - )) - rmfile ./site-lisp/guileint-1.5/hilit-scheme.el hunk ./site-lisp/guileint-1.5/inda-c.el 1 -;;; NAME: inda-c.el -;;; SYNOPSIS: Customizations of c-mode for the INDA course at NADA/KTH -;;; VERSION: 1.0 -;;; LAST CHANGE: 950827 -;;; CREATED: 950827 -;;; AUTHOR: Mikael Djurfeldt -;;; COPYRIGHT: (C) 1995 Mikael Djurfeldt -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. -;;; -;;; REQUIREMENTS: -;;; -;;; USAGE: -;;; -;;; BUGS: -;;; - -(require 'defmenu) - -;; A better C mode. -(fmakunbound 'c-mode) -(makunbound 'c-mode-map) -(fmakunbound 'c++-mode) -(makunbound 'c++-mode-map) -(makunbound 'c-style-alist) - -(autoload 'c++-mode "cc-mode" "C++ Editing Mode" t) -(autoload 'c-mode "cc-mode" "C Editing Mode" t) - -(setq auto-mode-alist - (append '(("\\.C$" . c++-mode) - ("\\.cc$" . c++-mode) - ("\\.c$" . c-mode) - ("\\.h$" . c-mode) - ) auto-mode-alist)) - -(defvar inda-c-menu-fixed-p nil) - -;; And tweak it to fit ckod. -(defun inda-c-mode-common-initialize () - (if (assoc 'substatement-open c-offsets-alist) - (c-set-offset 'substatement-open 0) - (c-set-offset 'block-open 'c-adaptive-block-open)) - (c-set-offset 'brace-list-open '+) - (c-set-offset 'arglist-cont '+) - ;; Fix the "C" menu... - (if (not inda-c-menu-fixed-p) - (progn - (fset 'c-advanced-menu (lookup-key c-mode-map [menu-bar c])) - (define-menu c-mode-map 'c "C" - '( - ("Compile" compile) - () - ("Indent buffer" indent-buffer) - ("Indent region" indent-region) - ("Indent definition" indent-defun) - () - ("Next Error" next-error) - ("Previous Error" previous-error) - ("First Error" first-error) - () - ("Advanced" c-advanced-menu) - )) - (setq inda-c-menu-fixed-p t)))) - -(add-hook 'c-mode-common-hook 'inda-c-mode-common-initialize) rmfile ./site-lisp/guileint-1.5/inda-c.el hunk ./site-lisp/guileint-1.5/inda-scheme.el 1 -;;; NAME: inda-scheme.el -;;; SYNOPSIS: Customizations of the scheme modes for -;;; the INDA course at NADA/KTH -;;; VERSION: 1.0 -;;; LAST CHANGE: 950827 -;;; CREATED: 950827 -;;; AUTHOR: Mikael Djurfeldt -;;; COPYRIGHT: (C) Mikael Djurfeldt 1995 -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. -;;; -;;; REQUIREMENTS: -;;; -;;; USAGE: -;;; -;;; BUGS: -;;; -;;; - -(require 'guile-init) - -;;; Customizations of the scheme modes - -(defun inda-scheme-mode-initializations () - (define-key scheme-mode-map "\r" 'newline-and-indent) - ;(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go) - (define-key scheme-mode-map [S-mouse-2] 'guile-frame-eval-at-click) - (define-key scheme-mode-map [triple-mouse-1] 'inda-mark-sexp) ;*fixme* - (define-key scheme-mode-map "\C-c\C-b" 'scheme-send-buffer) - (define-key scheme-mode-map "(" 'scheme-electric-open-paren) - (define-key scheme-mode-map "[" 'scheme-electric-open-paren) - (define-key scheme-mode-map ")" 'scheme-close-paren) - (define-key scheme-mode-map "]" 'scheme-close-paren) - (define-key scheme-mode-map "\M-?" 'guile-list-completions) - (define-key scheme-mode-map "\C-cd" 'guile-describe-variable) - (define-key scheme-mode-map "\M-\t" 'guile-complete-symbol) - (put 'procedure->macro 'scheme-indent-function 0) - (put 'procedure->memoizing-macro 'scheme-indent-function 0) - (put 'bind 'scheme-indent-function 1) - (put 'letrec* 'scheme-indent-function 1) - (put 'syntax-rules 'scheme-indent-function 1) - (put 'syntax-case 'scheme-indent-function 2) - (put 'define-syntax 'scheme-indent-function 1) - (put 'with-syntax 'scheme-indent-function 1)) - -(add-hook 'scheme-mode-hook (function inda-scheme-mode-initializations)) - -(defun scheme-electric-open-paren () - (interactive) - (insert last-input-char) - (let ((old-point (point))) - (indent-for-tab-command) - (if (not (eq (char-after (1- (point))) last-input-char)) - (goto-char old-point)))) - -(defun scheme-close-paren () - (interactive) - (insert last-input-char) - (if (guile-enhancedp) - (guile-repair-overlays)) - (if blink-paren-function - (funcall blink-paren-function))) - -(defun inda-send-definition (click) - "Position point and send definition to the inferior Scheme process." - (interactive "e") - (mouse-set-point click) - (sit-for 0) - (scheme-send-definition)) - -(defun inda-mark-sexp () - (interactive) - (beginning-of-defun) - (mark-sexp)) - -(defvar inda-read-only-overlay nil) - -(defun inda-inferior-initializations () - (setq guile-kill-buffer-on-death t) - ;; The following seems already to be done in comint-mode... - ;;(add-hook 'pre-command-hook (function comint-preinput-scroll-to-bottom)) - (setq comint-scroll-to-bottom-on-input 'this) - (setq comint-scroll-to-bottom-on-output nil) - - ;; Some key bindings. - (define-key inferior-scheme-mode-map "\C-a" 'comint-bol) - (define-key inferior-scheme-mode-map [C-a] 'comint-bol) - (define-key inferior-scheme-mode-map "\C-c\C-a" 'beginning-of-line) - (define-key inferior-scheme-mode-map [C-c C-a] 'beginning-of-line) - (define-key inferior-scheme-mode-map "\r" 'guile-send-input) - (define-key inferior-scheme-mode-map "\t" 'guile-indent-or-complete) - (define-key inferior-scheme-mode-map "\M-?" 'guile-list-completions) - (define-key inferior-scheme-mode-map "\C-cd" 'guile-describe-variable) - (define-key inferior-scheme-mode-map [C-c d] 'guile-describe-variable) - - ;; Create the read-only overlay. - (make-local-variable 'inda-read-only-overlay) - (cond ((not (overlayp inda-read-only-overlay)) - (setq inda-read-only-overlay (make-overlay 1 (point))) - (overlay-put inda-read-only-overlay 'modification-hooks - '(inda-barf-at-modifications)))) - - ;; Disable font-lock - (make-local-variable 'font-lock-fontify-region-function) - (setq font-lock-fontify-region-function 'ignore) - - ;; We don't want all comint modes to have these values - (add-hook 'comint-input-filter-functions - (function inda-make-input-memory) 'append 'local) - (add-hook 'comint-input-filter-functions - (function inda-extend-read-only-overlay) 'append 'local) - (add-hook 'comint-output-filter-functions - (function inda-extend-read-only-overlay) 'append 'local) - (add-hook 'comint-output-filter-functions - (function inda-reset-guile-last-output) 'append 'local) - ;; This is a bit kludgy... - (add-hook 'scheme-enter-input-wait-hook (function inda-boldify-previous-character)) -) - -;; No message about reason when process dies - -(setq guile-insert-reason nil) - -(add-hook 'inferior-scheme-mode-hook - (function inda-inferior-initializations) - 'append) - -(require 'defmenu) - -;; Scheme mode menu -;; -(fset 'scheme-advanced-menu - (make-menu - "Advanced" - '( - ("Sync with scheme" guile-sync-with-scheme - (and (> guile-n-enhanced-buffers 0) - (not (guile-synchronizedp)) - scheme-ready-p)) - ("Re-eval buffer" guile-reread-buffer (and (guile-attachedp) - scheme-ready-p)) - () - ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) - ("Normal edit" guile-normal-edit (and (guile-enhancedp) - (not (guile-attachedp)))) - () - ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) - ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) - ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) - ))) - -(define-menu scheme-mode-map 'scheme "Scheme" - '( - ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) - ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) - ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) - ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) - () - ("Indent buffer" indent-buffer) - ("Indent region" indent-region) - ("Indent definition" indent-defun) - () - ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) - ("Normal edit" guile-normal-edit (and (guile-enhancedp) - (not (guile-attachedp)))) - () - ("Attach buffer" guile-attach-buffer (and (comint-check-proc "*scheme*") - scheme-ready-p - (not (guile-attachedp)))) - ("Detach buffer" guile-detach-buffer (guile-attachedp)) - () - ("Re-init buffer" guile-reread-buffer (and (guile-attachedp) - scheme-ready-p)) - ("Find bad expressions" guile-check-all (> guile-n-enhanced-buffers 0)) - )) - -;(define-key scheme-mode-map [menu-bar interpret] 'undefined) - -;; Inferior scheme menu -;; -(define-menu inferior-scheme-mode-map 'scheme "Scheme" - '(("Start scheme" run-scheme (not (comint-check-proc "*scheme*"))) - ("Restart scheme" guile-restart-scheme (comint-check-proc "*scheme*")) - ("Exit scheme" guile-exit-scheme (comint-check-proc "*scheme*")) - () - ("Load file..." guile-load-file - (and (comint-check-proc "*scheme*") - scheme-ready-p)) - ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) - ("Find bad expressions" guile-check-all (comint-check-proc "*scheme*")) - () - ("Clear transcript" guile-clear-transcript (comint-check-proc "*scheme*")))) - -(define-key inferior-scheme-mode-map [menu-bar interpret] 'undefined) rmfile ./site-lisp/guileint-1.5/inda-scheme.el hunk ./site-lisp/guileint-1.5/scheme.el 1 -;;; scheme.el --- Scheme (and DSSSL) editing mode - -;; Copyright (C) 1986, 87, 88, 97, 1998 Free Software Foundation, Inc. - -;; Author: Bill Rozas -;; Adapted-by: Dave Love -;; Keywords: languages, lisp - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The major mode for editing Scheme-type Lisp code, very similar to -;; the Lisp mode documented in the Emacs manual. `dsssl-mode' is a -;; variant of scheme-mode for editing DSSSL specifications for SGML -;; documents. [As of Apr 1997, some pointers for DSSSL may be found, -;; for instance, at .] -;; All these Lisp-ish modes vary basically in details of the language -;; syntax they highlight/indent/index, but dsssl-mode uses "^;;;" as -;; the page-delimiter since ^L isn't normally a legal SGML character. -;; -;; For interacting with a Scheme interpreter See also `run-scheme' in -;; the `cmuscheme' package and also the implementation-specific -;; `xscheme' package. - -;; Here's a recipe to generate a TAGS file for DSSSL, by the way: -;; etags --lang=scheme --regex='/[ \t]*(\(mode\|element\)[ \t -;; ]+\([^ \t( -;; ]+\)/\2/' --regex='/[ \t]*(element[ \t -;; ]*([^)]+[ \t -;; ]+\([^)]+\)[ \t -;; ]*)/\1/' --regex='/(declare[^ \t -;; ]*[ \t -;; ]+\([^ \t -;; ]+\)/\1/' "$@" - -;;; Code: - -(require 'lisp-mode) - -(defvar scheme-mode-syntax-table nil) -(if (not scheme-mode-syntax-table) - (let ((i 0)) - (setq scheme-mode-syntax-table (make-syntax-table)) - (set-syntax-table scheme-mode-syntax-table) - - ;; Default is atom-constituent. - (while (< i 256) - (modify-syntax-entry i "_ ") - (setq i (1+ i))) - - ;; Word components. - (setq i ?0) - (while (<= i ?9) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - (setq i ?A) - (while (<= i ?Z) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - (setq i ?a) - (while (<= i ?z) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - - ;; Whitespace - (modify-syntax-entry ?\t " ") - (modify-syntax-entry ?\n "> ") - (modify-syntax-entry ?\f " ") - (modify-syntax-entry ?\r " ") - (modify-syntax-entry ? " ") - - ;; These characters are delimiters but otherwise undefined. - ;; Brackets and braces balance for editing convenience. - (modify-syntax-entry ?\[ "(] ") - (modify-syntax-entry ?\] ")[ ") - (modify-syntax-entry ?{ "(} ") - (modify-syntax-entry ?} "){ ") - (modify-syntax-entry ?\| " 23") - - ;; Other atom delimiters - (modify-syntax-entry ?\( "() ") - (modify-syntax-entry ?\) ")( ") - (modify-syntax-entry ?\; "< ") - (modify-syntax-entry ?\" "\" ") - (modify-syntax-entry ?' " p") - (modify-syntax-entry ?` " p") - - ;; Special characters - (modify-syntax-entry ?, "_ p") - (modify-syntax-entry ?@ "_ p") - (modify-syntax-entry ?# "_ p14") - (modify-syntax-entry ?\\ "\\ "))) - -(defvar scheme-mode-abbrev-table nil) -(define-abbrev-table 'scheme-mode-abbrev-table ()) - -(defvar scheme-imenu-generic-expression - '((nil - "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\|\\*\\)\\)*\\s-+(?\\(\\sw+\\)" 4) - ("Types" - "^(define-class\\s-+(?\\(\\sw+\\)" 1) - ("Macros" - "^(\\(defmacro\\|define-macro\\|define-syntax\\)\\s-+(?\\(\\sw+\\)" 2)) - "Imenu generic expression for Scheme mode. See `imenu-generic-expression'.") - -(defun scheme-mode-variables () - (set-syntax-table scheme-mode-syntax-table) - (setq local-abbrev-table scheme-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'lisp-fill-paragraph) - ;; Adaptive fill mode gets in the way of auto-fill, - ;; and should make no difference for explicit fill - ;; because lisp-fill-paragraph should do the job. - (make-local-variable 'adaptive-fill-mode) - (setq adaptive-fill-mode nil) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'lisp-mode-auto-fill) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'outline-regexp) - (setq outline-regexp ";;; \\|(....") - (make-local-variable 'comment-start) - (setq comment-start ";") - (make-local-variable 'comment-start-skip) - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'lisp-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'lisp-indent-function) - (set lisp-indent-function 'scheme-indent-function) - (make-local-variable 'scheme-mode-line-process) ;guileint added - (make-local-variable 'scheme-associated-process-buffer) ;guileint added - (setq mode-line-process '("" scheme-mode-line-process)) - (set (make-local-variable 'imenu-case-fold-search) t) - (setq imenu-generic-expression scheme-imenu-generic-expression) - (set (make-local-variable 'imenu-syntax-alist) - '(("+-*/.<>=?!$%_&~^:" . "w"))) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '((scheme-font-lock-keywords - scheme-font-lock-keywords-1 scheme-font-lock-keywords-2) - nil t (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun - (font-lock-mark-block-function . mark-defun)))) - -(defvar scheme-mode-line-process "") - -(defvar scheme-associated-process-buffer nil) ;guileint added - -(defvar scheme-mode-map nil - "Keymap for Scheme mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") - -(unless scheme-mode-map - (let ((map (make-sparse-keymap "Scheme"))) - (setq scheme-mode-map (make-sparse-keymap)) - (set-keymap-parent scheme-mode-map lisp-mode-shared-map) - (define-key scheme-mode-map [menu-bar] (make-sparse-keymap)) - (define-key scheme-mode-map [menu-bar scheme] - (cons "Scheme" map)) - (define-key map [run-scheme] '("Run Inferior Scheme" . run-scheme)) - (define-key map [uncomment-region] - '("Uncomment Out Region" . (lambda (beg end) - (interactive "r") - (comment-region beg end '(4))))) - (define-key map [comment-region] '("Comment Out Region" . comment-region)) - (define-key map [indent-region] '("Indent Region" . indent-region)) - (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) - (put 'comment-region 'menu-enable 'mark-active) - (put 'uncomment-region 'menu-enable 'mark-active) - (put 'indent-region 'menu-enable 'mark-active))) - -;; Used by cmuscheme -(defun scheme-mode-commands (map) - ;;(define-key map "\t" 'indent-for-tab-command) ; default - (define-key map "\177" 'backward-delete-char-untabify) - (define-key map "\e\C-q" 'indent-sexp)) - -;;;###autoload -(defun scheme-mode () - "Major mode for editing Scheme code. -Editing commands are similar to those of `lisp-mode'. - -In addition, if an inferior Scheme process is running, some additional -commands will be defined, for evaluating expressions and controlling -the interpreter, and the state of the process will be displayed in the -modeline of all Scheme buffers. The names of commands that interact -with the Scheme process start with \"xscheme-\" if you use the MIT -Scheme-specific `xscheme' package; for more information see the -documentation for `xscheme-interaction-mode'. Use \\[run-scheme] to -start an inferior Scheme using the more general `cmuscheme' package. - -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-mode-map} -Entry to this mode calls the value of `scheme-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (scheme-mode-initialize) - (scheme-mode-variables) - (run-hooks 'scheme-mode-hook)) - -(defun scheme-mode-initialize () - (use-local-map scheme-mode-map) - (setq major-mode 'scheme-mode) - (setq mode-name "Scheme")) - -(defgroup scheme nil - "Editing Scheme code" - :group 'lisp) - -(defcustom scheme-mit-dialect t - "If non-nil, scheme mode is specialized for MIT Scheme. -Set this to nil if you normally use another dialect." - :type 'boolean - :group 'scheme) - -(defcustom dsssl-sgml-declaration - " -" - "*An SGML declaration for the DSSSL file. -If it is defined as a string this will be inserted into an empty buffer -which is in `dsssl-mode'. It is typically James Clark's style-sheet -doctype, as required for Jade." - :type '(choice (string :tag "Specified string") - (const :tag "None" :value nil)) - :group 'scheme) - -(defcustom scheme-mode-hook nil - "Normal hook run when entering `scheme-mode'. -See `run-hooks'." - :type 'hook - :group 'scheme) - -(defcustom dsssl-mode-hook nil - "Normal hook run when entering `dsssl-mode'. -See `run-hooks'." - :type 'hook - :group 'scheme) - -;; This is shared by cmuscheme and xscheme. -(defcustom scheme-program-name "scheme" - "*Program invoked by the `run-scheme' command." - :type 'string - :group 'scheme) - -(defvar dsssl-imenu-generic-expression - ;; Perhaps this should also look for the style-sheet DTD tags. I'm - ;; not sure it's the best way to organize it; perhaps one type - ;; should be at the first level, though you don't see this anyhow if - ;; it gets split up. - '(("Defines" - "^(define\\s-+(?\\(\\sw+\\)" 1) - ("Modes" - "^\\s-*(mode\\s-+\\(\\(\\sw\\|\\s-\\)+\\)" 1) - ("Elements" - ;; (element foo ...) or (element (foo bar ...) ...) - ;; Fixme: Perhaps it should do `root'. - "^\\s-*(element\\s-+(?\\(\\(\\sw\\|\\s-\\)+\\))?" 1) - ("Declarations" - "^(declare\\(-\\sw+\\)+\\>\\s-+\\(\\sw+\\)" 2)) - "Imenu generic expression for DSSSL mode. See `imenu-generic-expression'.") - -(defconst scheme-font-lock-keywords-1 - (eval-when-compile - (list - ;; - ;; Declarations. Hannes Haug says - ;; this works for SOS, STklos, SCOOPS, Meroon and Tiny CLOS. - (list (concat "(\\(define\\*?\\(" - ;; Function names. - "\\(\\|-public\\|-method\\|-generic\\|\\*\\(-procedure\\)?\\)\\|" - ;; Macro names, as variable names. A bit dubious, this. - "\\(-syntax\\|-macro\\)\\|" - ;; Class names. - "-class" - ;; Guile modules. - "\\|-module" - "\\)\\)\\>" - ;; Any whitespace and declared object. - "[ \t]*(?" - "\\(\\sw+\\)?") - '(1 font-lock-keyword-face) - '(6 (cond ((match-beginning 3) font-lock-function-name-face) - ((match-beginning 5) font-lock-variable-name-face) - (t font-lock-type-face)) - nil t)) - )) - "Subdued expressions to highlight in Scheme modes.") - -(defconst scheme-font-lock-keywords-2 - (append scheme-font-lock-keywords-1 - (eval-when-compile - (list - ;; - ;; Control structures. - (cons - (concat - "(" (regexp-opt - '("begin" "call-with-current-continuation" "call/cc" - "call-with-input-file" "call-with-output-file" "case" "cond" - "do" "else" "for-each" "if" "lambda" "lambda*" - "let" "let*" "let-syntax" "letrec" "letrec-syntax" - ;; Hannes Haug wants: - "and" "or" "delay" - ;; Stefan Monnier says don't bother: - ;;"quasiquote" "quote" "unquote" "unquote-splicing" - "map" "syntax" "syntax-rules" "use-modules" "define-module") t) - "\\>") 1) - ;; - ;; David Fox for SOS/STklos class specifiers. - '("\\<<\\sw+>\\>" . font-lock-type-face) - ;; - ;; Scheme `:' keywords as builtins. - '("\\<:\\sw+\\>" . font-lock-builtin-face) - ))) - "Gaudy expressions to highlight in Scheme modes.") - -(defvar scheme-font-lock-keywords scheme-font-lock-keywords-1 - "Default expressions to highlight in Scheme modes.") - -;;;###autoload -(defun dsssl-mode () - "Major mode for editing DSSSL code. -Editing commands are similar to those of `lisp-mode'. - -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-mode-map} -Entering this mode runs the hooks `scheme-mode-hook' and then -`dsssl-mode-hook' and inserts the value of `dsssl-sgml-declaration' if -that variable's value is a string." - (interactive) - (kill-all-local-variables) - (use-local-map scheme-mode-map) - (scheme-mode-initialize) - (make-local-variable 'page-delimiter) - (setq page-delimiter "^;;;" ; ^L not valid SGML char - major-mode 'dsssl-mode - mode-name "DSSSL") - ;; Insert a suitable SGML declaration into an empty buffer. - (and (zerop (buffer-size)) - (stringp dsssl-sgml-declaration) - (not buffer-read-only) - (insert dsssl-sgml-declaration)) - (scheme-mode-variables) - (setq font-lock-defaults '(dsssl-font-lock-keywords - nil t (("+-*/.<>=?$%_&~^:" . "w")) - beginning-of-defun - (font-lock-mark-block-function . mark-defun))) - (set (make-local-variable 'imenu-case-fold-search) nil) - (setq imenu-generic-expression dsssl-imenu-generic-expression) - (set (make-local-variable 'imenu-syntax-alist) - '(("+-*/.<>=?$%_&~^:" . "w"))) - (run-hooks 'scheme-mode-hook) - (run-hooks 'dsssl-mode-hook)) - -;; Extra syntax for DSSSL. This isn't separated from Scheme, but -;; shouldn't cause much trouble in scheme-mode. -(put 'element 'scheme-indent-function 1) -(put 'mode 'scheme-indent-function 1) -(put 'with-mode 'scheme-indent-function 1) -(put 'make 'scheme-indent-function 1) -(put 'style 'scheme-indent-function 1) -(put 'root 'scheme-indent-function 1) - -(defvar dsssl-font-lock-keywords - (eval-when-compile - (list - ;; Similar to Scheme - (list "(\\(define\\(-\\w+\\)?\\)\\>[ ]*\\\((?\\)\\(\\sw+\\)\\>" - '(1 font-lock-keyword-face) - '(4 font-lock-function-name-face)) - (cons - (concat "(\\(" - ;; (make-regexp '("case" "cond" "else" "if" "lambda" - ;; "let" "let*" "letrec" "and" "or" "map" "with-mode")) - "and\\|c\\(ase\\|ond\\)\\|else\\|if\\|" - "l\\(ambda\\|ambda\\*\\|et\\(\\|*\\|rec\\)\\)\\|map\\|or\\|with-mode" - "\\)\\>") - 1) - ;; DSSSL syntax - '("(\\(element\\|mode\\|declare-\\w+\\)\\>[ ]*\\(\\sw+\\)" - (1 font-lock-keyword-face) - (2 font-lock-type-face)) - '("(\\(element\\)\\>[ ]*(\\(\\S)+\\))" - (1 font-lock-keyword-face) - (2 font-lock-type-face)) - '("\\<\\sw+:\\>" . font-lock-constant-face) ; trailing `:' c.f. scheme - ;; SGML markup (from sgml-mode) : - '("<\\([!?][-a-z0-9]+\\)" 1 font-lock-keyword-face) - '("<\\(/?[-a-z0-9]+\\)" 1 font-lock-function-name-face))) - "Default expressions to highlight in DSSSL mode.") - - -(defvar calculate-lisp-indent-last-sexp) - -;; Copied from lisp-indent-function, but with gets of -;; scheme-indent-{function,hook}. -(defun scheme-indent-function (indent-point state) - (let ((normal-indent (current-column))) - (goto-char (1+ (elt state 1))) - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) - (if (and (elt state 2) - (not (looking-at "\\sw\\|\\s_"))) - ;; car of form doesn't seem to be a a symbol - (progn - (if (not (> (save-excursion (forward-line 1) (point)) - calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are - ;; inside the innermost containing sexp. - (backward-prefix-chars) - (current-column)) - (let ((function (buffer-substring (point) - (progn (forward-sexp 1) (point)))) - method) - (setq method (or (get (intern-soft function) 'scheme-indent-function) - (get (intern-soft function) 'scheme-indent-hook))) - (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) - (lisp-indent-defform state indent-point)) - ((integerp method) - (lisp-indent-specform method state - indent-point normal-indent)) - (method - (funcall method state indent-point normal-indent))))))) - - -;;; Let is different in Scheme - -(defun would-be-symbol (string) - (not (string-equal (substring string 0 1) "("))) - -(defun next-sexp-as-string () - ;; Assumes that it is protected by a save-excursion - (forward-sexp 1) - (let ((the-end (point))) - (backward-sexp 1) - (buffer-substring (point) the-end))) - -;; This is correct but too slow. -;; The one below works almost always. -;;(defun scheme-let-indent (state indent-point) -;; (if (would-be-symbol (next-sexp-as-string)) -;; (scheme-indent-specform 2 state indent-point) -;; (scheme-indent-specform 1 state indent-point))) - -(defun scheme-let-indent (state indent-point normal-indent) - (skip-chars-forward " \t") - (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]") - (lisp-indent-specform 2 state indent-point normal-indent) - (lisp-indent-specform 1 state indent-point normal-indent))) - -;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - -(put 'begin 'scheme-indent-function 0) -(put 'case 'scheme-indent-function 1) -(put 'delay 'scheme-indent-function 0) -(put 'do 'scheme-indent-function 2) -(put 'lambda 'scheme-indent-function 1) -(put 'let 'scheme-indent-function 'scheme-let-indent) -(put 'let* 'scheme-indent-function 1) -(put 'letrec 'scheme-indent-function 1) -(put 'sequence 'scheme-indent-function 0) ; SICP, not r4rs -(put 'let-syntax 'scheme-indent-function 1) -(put 'letrec-syntax 'scheme-indent-function 1) -(put 'syntax-rules 'scheme-indent-function 1) - - -(put 'call-with-input-file 'scheme-indent-function 1) -(put 'with-input-from-file 'scheme-indent-function 1) -(put 'with-input-from-port 'scheme-indent-function 1) -(put 'call-with-output-file 'scheme-indent-function 1) -(put 'with-output-to-file 'scheme-indent-function 1) -(put 'with-output-to-port 'scheme-indent-function 1) -(put 'call-with-values 'scheme-indent-function 1) ; r5rs? -(put 'dynamic-wind 'scheme-indent-function 3) ; r5rs? - -;;;; MIT Scheme specific indentation. - -(if scheme-mit-dialect - (progn - (put 'fluid-let 'scheme-indent-function 1) - (put 'in-package 'scheme-indent-function 1) - (put 'local-declare 'scheme-indent-function 1) - (put 'macro 'scheme-indent-function 1) - (put 'make-environment 'scheme-indent-function 0) - (put 'named-lambda 'scheme-indent-function 1) - (put 'using-syntax 'scheme-indent-function 1) - - (put 'with-input-from-string 'scheme-indent-function 1) - (put 'with-output-to-string 'scheme-indent-function 0) - (put 'with-values 'scheme-indent-function 1) - - (put 'syntax-table-define 'scheme-indent-function 2) - (put 'list-transform-positive 'scheme-indent-function 1) - (put 'list-transform-negative 'scheme-indent-function 1) - (put 'list-search-positive 'scheme-indent-function 1) - (put 'list-search-negative 'scheme-indent-function 1) - - (put 'access-components 'scheme-indent-function 1) - (put 'assignment-components 'scheme-indent-function 1) - (put 'combination-components 'scheme-indent-function 1) - (put 'comment-components 'scheme-indent-function 1) - (put 'conditional-components 'scheme-indent-function 1) - (put 'disjunction-components 'scheme-indent-function 1) - (put 'declaration-components 'scheme-indent-function 1) - (put 'definition-components 'scheme-indent-function 1) - (put 'delay-components 'scheme-indent-function 1) - (put 'in-package-components 'scheme-indent-function 1) - (put 'lambda-components 'scheme-indent-function 1) - (put 'lambda-components* 'scheme-indent-function 1) - (put 'lambda-components** 'scheme-indent-function 1) - (put 'open-block-components 'scheme-indent-function 1) - (put 'pathname-components 'scheme-indent-function 1) - (put 'procedure-components 'scheme-indent-function 1) - (put 'sequence-components 'scheme-indent-function 1) - (put 'unassigned\?-components 'scheme-indent-function 1) - (put 'unbound\?-components 'scheme-indent-function 1) - (put 'variable-components 'scheme-indent-function 1))) - -(provide 'scheme) - -;;; scheme.el ends here rmfile ./site-lisp/guileint-1.5/scheme.el hunk ./site-lisp/guileint-1.5/xscheme.el 1 -;;; xscheme.el --- run Scheme under Emacs - -;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: languages, lisp - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; A major mode for editing Scheme and interacting with MIT's C-Scheme. -;; -;; Requires C-Scheme release 5 or later -;; Changes to Control-G handler require runtime version 13.85 or later - -;;; Code: - -(require 'scheme) - -(defvar scheme-program-name "scheme" - "*Program invoked by the `run-scheme' command.") - -(defvar scheme-band-name nil - "*Band loaded by the `run-scheme' command.") - -(defvar scheme-program-arguments nil - "*Arguments passed to the Scheme program by the `run-scheme' command.") - -(defvar xscheme-allow-pipelined-evaluation t - "If non-nil, an expression may be transmitted while another is evaluating. -Otherwise, attempting to evaluate an expression before the previous expression -has finished evaluating will signal an error.") - -(defvar xscheme-startup-message - "This is the Scheme process buffer. -Type \\[advertised-xscheme-send-previous-expression] to evaluate the expression before point. -Type \\[xscheme-send-control-g-interrupt] to abort evaluation. -Type \\[describe-mode] for more information. - -" - "String to insert into Scheme process buffer first time it is started. -Is processed with `substitute-command-keys' first.") - -(defvar xscheme-signal-death-message nil - "If non-nil, causes a message to be generated when the Scheme process dies.") - -(defun xscheme-evaluation-commands (keymap) - (define-key keymap "\e\C-x" 'xscheme-send-definition) - (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) - (define-key keymap "\eo" 'xscheme-send-buffer) - (define-key keymap "\ez" 'xscheme-send-definition) - (define-key keymap "\e\C-m" 'xscheme-send-previous-expression) - (define-key keymap "\e\C-z" 'xscheme-send-region)) - -(defun xscheme-interrupt-commands (keymap) - (define-key keymap "\C-c\C-s" 'xscheme-select-process-buffer) - (define-key keymap "\C-c\C-b" 'xscheme-send-breakpoint-interrupt) - (define-key keymap "\C-c\C-c" 'xscheme-send-control-g-interrupt) - (define-key keymap "\C-c\C-u" 'xscheme-send-control-u-interrupt) - (define-key keymap "\C-c\C-x" 'xscheme-send-control-x-interrupt)) - -(xscheme-evaluation-commands scheme-mode-map) -(xscheme-interrupt-commands scheme-mode-map) - -(defun run-scheme (command-line) - "Run MIT Scheme in an inferior process. -Output goes to the buffer `*scheme*'. -With argument, asks for a command line." - (interactive - (list (let ((default - (or xscheme-process-command-line - (xscheme-default-command-line)))) - (if current-prefix-arg - (read-string "Run Scheme: " default) - default)))) - (setq xscheme-process-command-line command-line) - (switch-to-buffer (xscheme-start-process command-line))) - -(defun reset-scheme () - "Reset the Scheme process." - (interactive) - (let ((process (get-process "scheme"))) - (cond ((or (not process) - (not (eq (process-status process) 'run)) - (yes-or-no-p -"The Scheme process is running, are you SURE you want to reset it? ")) - (message "Resetting Scheme process...") - (if process (kill-process process t)) - (xscheme-start-process xscheme-process-command-line) - (message "Resetting Scheme process...done"))))) - -(defun xscheme-default-command-line () - (concat scheme-program-name " -emacs" - (if scheme-program-arguments - (concat " " scheme-program-arguments) - "") - (if scheme-band-name - (concat " -band " scheme-band-name) - ""))) - -;;;; Interaction Mode - -(defun scheme-interaction-mode () - "Major mode for interacting with the inferior Scheme process. -Like scheme-mode except that: - -\\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input -\\[xscheme-yank-previous-send] yanks the expression most recently sent to Scheme - -All output from the Scheme process is written in the Scheme process -buffer, which is initially named \"*scheme*\". The result of -evaluating a Scheme expression is also printed in the process buffer, -preceded by the string \";Value: \" to highlight it. If the process -buffer is not visible at that time, the value will also be displayed -in the minibuffer. If an error occurs, the process buffer will -automatically pop up to show you the error message. - -While the Scheme process is running, the modelines of all buffers in -scheme-mode are modified to show the state of the process. The -possible states and their meanings are: - -input waiting for input -run evaluating -gc garbage collecting - -The process buffer's modeline contains additional information where -the buffer's name is normally displayed: the command interpreter level -and type. - -Scheme maintains a stack of command interpreters. Every time an error -or breakpoint occurs, the current command interpreter is pushed on the -command interpreter stack, and a new command interpreter is started. -One example of why this is done is so that an error that occurs while -you are debugging another error will not destroy the state of the -initial error, allowing you to return to it after the second error has -been fixed. - -The command interpreter level indicates how many interpreters are in -the command interpreter stack. It is initially set to one, and it is -incremented every time that stack is pushed, and decremented every -time it is popped. The following commands are useful for manipulating -the command interpreter stack: - -\\[xscheme-send-breakpoint-interrupt] pushes the stack once -\\[xscheme-send-control-u-interrupt] pops the stack once -\\[xscheme-send-control-g-interrupt] pops everything off -\\[xscheme-send-control-x-interrupt] aborts evaluation, doesn't affect stack - -Some possible command interpreter types and their meanings are: - -[Evaluator] read-eval-print loop for evaluating expressions -[Debugger] single character commands for debugging errors -[Where] single character commands for examining environments - -Starting with release 6.2 of Scheme, the latter two types of command -interpreters will change the major mode of the Scheme process buffer -to scheme-debugger-mode , in which the evaluation commands are -disabled, and the keys which normally self insert instead send -themselves to the Scheme process. The command character ? will list -the available commands. - -For older releases of Scheme, the major mode will be be -scheme-interaction-mode , and the command characters must be sent as -if they were expressions. - -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-interaction-mode-map} - -Entry to this mode calls the value of scheme-interaction-mode-hook -with no args, if that value is non-nil. - Likewise with the value of scheme-mode-hook. - scheme-interaction-mode-hook is called after scheme-mode-hook." - (interactive) - (kill-all-local-variables) - (scheme-interaction-mode-initialize) - (scheme-mode-variables) - (make-local-variable 'xscheme-previous-send) - (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) - -(defun scheme-interaction-mode-initialize () - (use-local-map scheme-interaction-mode-map) - (setq major-mode 'scheme-interaction-mode) - (setq mode-name "Scheme Interaction")) - -(defun scheme-interaction-mode-commands (keymap) - (define-key keymap "\C-c\C-m" 'xscheme-send-current-line) - (define-key keymap "\C-c\C-p" 'xscheme-send-proceed) - (define-key keymap "\C-c\C-y" 'xscheme-yank-previous-send)) - -(defvar scheme-interaction-mode-map nil) -(if (not scheme-interaction-mode-map) - (progn - (setq scheme-interaction-mode-map (make-keymap)) - (scheme-mode-commands scheme-interaction-mode-map) - (xscheme-interrupt-commands scheme-interaction-mode-map) - (xscheme-evaluation-commands scheme-interaction-mode-map) - (scheme-interaction-mode-commands scheme-interaction-mode-map))) - -(defun xscheme-enter-interaction-mode () - (save-excursion - (set-buffer (xscheme-process-buffer)) - (if (not (eq major-mode 'scheme-interaction-mode)) - (if (eq major-mode 'scheme-debugger-mode) - (scheme-interaction-mode-initialize) - (scheme-interaction-mode))))) - -(fset 'advertised-xscheme-send-previous-expression - 'xscheme-send-previous-expression) - -;;;; Debugger Mode - -(defun scheme-debugger-mode () - "Major mode for executing the Scheme debugger. -Like scheme-mode except that the evaluation commands -are disabled, and characters that would normally be self inserting are -sent to the Scheme process instead. Typing ? will show you which -characters perform useful functions. - -Commands: -\\{scheme-debugger-mode-map}" - (error "Illegal entry to scheme-debugger-mode")) - -(defun scheme-debugger-mode-initialize () - (use-local-map scheme-debugger-mode-map) - (setq major-mode 'scheme-debugger-mode) - (setq mode-name "Scheme Debugger")) - -(defun scheme-debugger-mode-commands (keymap) - (let ((char ? )) - (while (< char 127) - (define-key keymap (char-to-string char) 'scheme-debugger-self-insert) - (setq char (1+ char))))) - -(defvar scheme-debugger-mode-map nil) -(if (not scheme-debugger-mode-map) - (progn - (setq scheme-debugger-mode-map (make-keymap)) - (scheme-mode-commands scheme-debugger-mode-map) - (xscheme-interrupt-commands scheme-debugger-mode-map) - (scheme-debugger-mode-commands scheme-debugger-mode-map))) - -(defun scheme-debugger-self-insert () - "Transmit this character to the Scheme process." - (interactive) - (xscheme-send-char last-command-char)) - -(defun xscheme-enter-debugger-mode (prompt-string) - (save-excursion - (set-buffer (xscheme-process-buffer)) - (if (not (eq major-mode 'scheme-debugger-mode)) - (progn - (if (not (eq major-mode 'scheme-interaction-mode)) - (scheme-interaction-mode)) - (scheme-debugger-mode-initialize))))) - -(defun xscheme-debugger-mode-p () - (let ((buffer (xscheme-process-buffer))) - (and buffer - (save-excursion - (set-buffer buffer) - (eq major-mode 'scheme-debugger-mode))))) - -;;;; Evaluation Commands - -(defun xscheme-send-string (&rest strings) - "Send the string arguments to the Scheme process. -The strings are concatenated and terminated by a newline." - (cond ((not (xscheme-process-running-p)) - (if (yes-or-no-p "The Scheme process has died. Reset it? ") - (progn - (reset-scheme) - (xscheme-wait-for-process) - (goto-char (point-max)) - (apply 'insert-before-markers strings) - (xscheme-send-string-1 strings)))) - ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) - ((and (not xscheme-allow-pipelined-evaluation) - xscheme-running-p) - (error "No sends allowed while Scheme running")) - (t (xscheme-send-string-1 strings)))) - -(defun xscheme-send-string-1 (strings) - (let ((string (apply 'concat strings))) - (xscheme-send-string-2 string) - (if (eq major-mode 'scheme-interaction-mode) - (setq xscheme-previous-send string)))) - -(defun xscheme-send-string-2 (string) - (let ((process (get-process "scheme"))) - (send-string process (concat string "\n")) - (if (xscheme-process-buffer-current-p) - (set-marker (process-mark process) (point))))) - -(defun xscheme-yank-previous-send () - "Insert the most recent expression at point." - (interactive) - (push-mark) - (insert xscheme-previous-send)) - -(defun xscheme-select-process-buffer () - "Select the Scheme process buffer and move to its output point." - (interactive) - (let ((process (or (get-process "scheme") (error "No scheme process")))) - (let ((buffer (or (process-buffer process) (error "No process buffer")))) - (let ((window (get-buffer-window buffer))) - (if window - (select-window window) - (switch-to-buffer buffer)) - (goto-char (process-mark process)))))) - -(defun xscheme-send-region (start end) - "Send the current region to the Scheme process. -The region is sent terminated by a newline." - (interactive "r") - (if (xscheme-process-buffer-current-p) - (progn (goto-char end) - (set-marker (process-mark (get-process "scheme")) end))) - (xscheme-send-string (buffer-substring start end))) - -(defun xscheme-send-definition () - "Send the current definition to the Scheme process. -If the current line begins with a non-whitespace character, -parse an expression from the beginning of the line and send that instead." - (interactive) - (let ((start nil) (end nil)) - (save-excursion - (end-of-defun) - (setq end (point)) - (if (re-search-backward "^\\s(" nil t) - (setq start (point)) - (error "Can't find definition"))) - (xscheme-send-region start end))) - -(defun xscheme-send-next-expression () - "Send the expression to the right of `point' to the Scheme process." - (interactive) - (let ((start (point))) - (xscheme-send-region start (save-excursion (forward-sexp) (point))))) - -(defun xscheme-send-previous-expression () - "Send the expression to the left of `point' to the Scheme process." - (interactive) - (let ((end (point))) - (xscheme-send-region (save-excursion (backward-sexp) (point)) end))) - -(defun xscheme-send-current-line () - "Send the current line to the Scheme process. -Useful for working with debugging Scheme under adb." - (interactive) - (let ((line - (save-excursion - (beginning-of-line) - (let ((start (point))) - (end-of-line) - (buffer-substring start (point)))))) - (end-of-line) - (insert ?\n) - (xscheme-send-string-2 line))) - -(defun xscheme-send-buffer () - "Send the current buffer to the Scheme process." - (interactive) - (if (xscheme-process-buffer-current-p) - (error "Not allowed to send this buffer's contents to Scheme")) - (xscheme-send-region (point-min) (point-max))) - -(defun xscheme-send-char (char) - "Prompt for a character and send it to the Scheme process." - (interactive "cCharacter to send: ") - (send-string "scheme" (char-to-string char))) - -;;;; Interrupts - -(defun xscheme-send-breakpoint-interrupt () - "Cause the Scheme process to enter a breakpoint." - (interactive) - (xscheme-send-interrupt ?b nil)) - -(defun xscheme-send-proceed () - "Cause the Scheme process to proceed from a breakpoint." - (interactive) - (send-string "scheme" "(proceed)\n")) - -(defun xscheme-send-control-g-interrupt () - "Cause the Scheme processor to halt and flush input. -Control returns to the top level rep loop." - (interactive) - (let ((inhibit-quit t)) - (cond ((not xscheme-control-g-synchronization-p) - (interrupt-process "scheme")) - (xscheme-control-g-disabled-p - (message "Relax...")) - (t - (setq xscheme-control-g-disabled-p t) - (message "Sending C-G interrupt to Scheme...") - (interrupt-process "scheme") - (send-string "scheme" (char-to-string 0)))))) - -(defun xscheme-send-control-u-interrupt () - "Cause the Scheme process to halt, returning to previous rep loop." - (interactive) - (xscheme-send-interrupt ?u t)) - -(defun xscheme-send-control-x-interrupt () - "Cause the Scheme process to halt, returning to current rep loop." - (interactive) - (xscheme-send-interrupt ?x t)) - -;;; This doesn't really work right -- Scheme just gobbles the first -;;; character in the input. There is no way for us to guarantee that -;;; the argument to this procedure is the first char unless we put -;;; some kind of marker in the input stream. - -(defun xscheme-send-interrupt (char mark-p) - "Send a ^A type interrupt to the Scheme process." - (interactive "cInterrupt character to send: ") - (quit-process "scheme") - (send-string "scheme" (char-to-string char)) - (if (and mark-p xscheme-control-g-synchronization-p) - (send-string "scheme" (char-to-string 0)))) - -;;;; Internal Variables - -(defvar xscheme-process-command-line nil - "Command used to start the most recent Scheme process.") - -(defvar xscheme-previous-send "" - "Most recent expression transmitted to the Scheme process.") - -(defvar xscheme-process-filter-state 'idle - "State of scheme process escape reader state machine: -idle waiting for an escape sequence -reading-type received an altmode but nothing else -reading-string reading prompt string") - -(defvar xscheme-running-p nil - "This variable, if nil, indicates that the scheme process is -waiting for input. Otherwise, it is busy evaluating something.") - -(defconst xscheme-control-g-synchronization-p t - "If non-nil, insert markers in the scheme input stream to indicate when -control-g interrupts were signalled. Do not allow more control-g's to be -signalled until the scheme process acknowledges receipt.") - -(defvar xscheme-control-g-disabled-p nil - "This variable, if non-nil, indicates that a control-g is being processed -by the scheme process, so additional control-g's are to be ignored.") - -(defvar xscheme-allow-output-p t - "This variable, if nil, prevents output from the scheme process -from being inserted into the process-buffer.") - -(defvar xscheme-prompt "" - "The current scheme prompt string.") - -(defvar xscheme-string-accumulator "" - "Accumulator for the string being received from the scheme process.") - -(defvar xscheme-string-receiver nil - "Procedure to send the string argument from the scheme process.") - -(defvar xscheme-start-hook nil - "If non-nil, a procedure to call when the Scheme process is started. -When called, the current buffer will be the Scheme process-buffer.") - -(defvar xscheme-runlight-string nil) -(defvar xscheme-mode-string nil) -(defvar xscheme-filter-input nil) - -;;;; Basic Process Control - -(defun xscheme-start-process (command-line) - (let ((buffer (get-buffer-create "*scheme*"))) - (let ((process (get-buffer-process buffer))) - (save-excursion - (set-buffer buffer) - (if (and process (memq (process-status process) '(run stop))) - (set-marker (process-mark process) (point-max)) - (progn (if process (delete-process process)) - (goto-char (point-max)) - (scheme-interaction-mode) - (if (bobp) - (insert-before-markers - (substitute-command-keys xscheme-startup-message))) - (setq process - (let ((process-connection-type nil)) - (apply 'start-process - (cons "scheme" - (cons buffer - (xscheme-parse-command-line - command-line)))))) - (set-marker (process-mark process) (point-max)) - (xscheme-process-filter-initialize t) - (xscheme-modeline-initialize) - (set-process-sentinel process 'xscheme-process-sentinel) - (set-process-filter process 'xscheme-process-filter) - (run-hooks 'xscheme-start-hook))))) - buffer)) - -(defun xscheme-parse-command-line (string) - (setq string (substitute-in-file-name string)) - (let ((start 0) - (result '())) - (while start - (let ((index (string-match "[ \t]" string start))) - (setq start - (cond ((not index) - (setq result - (cons (substring string start) - result)) - nil) - ((= index start) - (string-match "[^ \t]" string start)) - (t - (setq result - (cons (substring string start index) - result)) - (1+ index)))))) - (nreverse result))) - -(defun xscheme-wait-for-process () - (sleep-for 2) - (while xscheme-running-p - (sleep-for 1))) - -(defun xscheme-process-running-p () - "True iff there is a Scheme process whose status is `run'." - (let ((process (get-process "scheme"))) - (and process - (eq (process-status process) 'run)))) - -(defun xscheme-process-buffer () - (let ((process (get-process "scheme"))) - (and process (process-buffer process)))) - -(defun xscheme-process-buffer-window () - (let ((buffer (xscheme-process-buffer))) - (and buffer (get-buffer-window buffer)))) - -(defun xscheme-process-buffer-current-p () - "True iff the current buffer is the Scheme process buffer." - (eq (xscheme-process-buffer) (current-buffer))) - -;;;; Process Filter - -(defun xscheme-process-sentinel (proc reason) - (xscheme-process-filter-initialize (eq reason 'run)) - (if (eq reason 'run) - (xscheme-modeline-initialize) - (progn - (setq scheme-mode-line-process "") - (setq xscheme-mode-string "no process"))) - (if (and (not (memq reason '(run stop))) - xscheme-signal-death-message) - (progn (beep) - (message -"The Scheme process has died! Do M-x reset-scheme to restart it")))) - -(defun xscheme-process-filter-initialize (running-p) - (setq xscheme-process-filter-state 'idle) - (setq xscheme-running-p running-p) - (setq xscheme-control-g-disabled-p nil) - (setq xscheme-allow-output-p t) - (setq xscheme-prompt "") - (setq scheme-mode-line-process '(": " xscheme-runlight-string))) - -(defun xscheme-process-filter (proc string) - (let ((xscheme-filter-input string)) - (while xscheme-filter-input - (cond ((eq xscheme-process-filter-state 'idle) - (let ((start (string-match "\e" xscheme-filter-input))) - (if start - (progn - (xscheme-process-filter-output - (substring xscheme-filter-input 0 start)) - (setq xscheme-filter-input - (substring xscheme-filter-input (1+ start))) - (setq xscheme-process-filter-state 'reading-type)) - (let ((string xscheme-filter-input)) - (setq xscheme-filter-input nil) - (xscheme-process-filter-output string))))) - ((eq xscheme-process-filter-state 'reading-type) - (if (zerop (length xscheme-filter-input)) - (setq xscheme-filter-input nil) - (let ((char (aref xscheme-filter-input 0))) - (setq xscheme-filter-input - (substring xscheme-filter-input 1)) - (let ((entry (assoc char xscheme-process-filter-alist))) - (if entry - (funcall (nth 2 entry) (nth 1 entry)) - (progn - (xscheme-process-filter-output ?\e char) - (setq xscheme-process-filter-state 'idle))))))) - ((eq xscheme-process-filter-state 'reading-string) - (let ((start (string-match "\e" xscheme-filter-input))) - (if start - (let ((string - (concat xscheme-string-accumulator - (substring xscheme-filter-input 0 start)))) - (setq xscheme-filter-input - (substring xscheme-filter-input (1+ start))) - (setq xscheme-process-filter-state 'idle) - (funcall xscheme-string-receiver string)) - (progn - (setq xscheme-string-accumulator - (concat xscheme-string-accumulator - xscheme-filter-input)) - (setq xscheme-filter-input nil))))) - (t - (error "Scheme process filter -- bad state")))))) - -;;;; Process Filter Output - -(defun xscheme-process-filter-output (&rest args) - (if xscheme-allow-output-p - (let ((string (apply 'concat args))) - (save-excursion - (xscheme-goto-output-point) - (while (string-match "\\(\007\\|\f\\)" string) - (let ((start (match-beginning 0)) - (end (match-end 0))) - (insert-before-markers (substring string 0 start)) - (if (= ?\f (aref string start)) - (progn - (if (not (bolp)) - (insert-before-markers ?\n)) - (insert-before-markers ?\f)) - (beep)) - (setq string (substring string (1+ start))))) - (insert-before-markers string))))) - -(defun xscheme-guarantee-newlines (n) - (if xscheme-allow-output-p - (save-excursion - (xscheme-goto-output-point) - (let ((stop nil)) - (while (and (not stop) - (bolp)) - (setq n (1- n)) - (if (bobp) - (setq stop t) - (backward-char)))) - (xscheme-goto-output-point) - (while (> n 0) - (insert-before-markers ?\n) - (setq n (1- n)))))) - -(defun xscheme-goto-output-point () - (let ((process (get-process "scheme"))) - (set-buffer (process-buffer process)) - (goto-char (process-mark process)))) - -(defun xscheme-modeline-initialize () - (setq xscheme-runlight-string "") - (setq xscheme-mode-string "") - (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string))) - -(defun xscheme-set-runlight (runlight) - (setq xscheme-runlight-string runlight) - (force-mode-line-update t)) - -;;;; Process Filter Operations - -(defvar xscheme-process-filter-alist - '((?D xscheme-enter-debugger-mode - xscheme-process-filter:string-action) - (?E xscheme-eval - xscheme-process-filter:string-action) - (?P xscheme-set-prompt-variable - xscheme-process-filter:string-action) - (?R xscheme-enter-interaction-mode - xscheme-process-filter:simple-action) - (?b xscheme-start-gc - xscheme-process-filter:simple-action) - (?e xscheme-finish-gc - xscheme-process-filter:simple-action) - (?f xscheme-exit-input-wait - xscheme-process-filter:simple-action) - (?g xscheme-enable-control-g - xscheme-process-filter:simple-action) - (?i xscheme-prompt-for-expression - xscheme-process-filter:string-action) - (?m xscheme-message - xscheme-process-filter:string-action) - (?n xscheme-prompt-for-confirmation - xscheme-process-filter:string-action) - (?o xscheme-output-goto - xscheme-process-filter:simple-action) - (?p xscheme-set-prompt - xscheme-process-filter:string-action) - (?s xscheme-enter-input-wait - xscheme-process-filter:simple-action) - (?v xscheme-write-value - xscheme-process-filter:string-action) - (?w xscheme-cd - xscheme-process-filter:string-action) - (?z xscheme-display-process-buffer - xscheme-process-filter:simple-action) - (?c xscheme-unsolicited-read-char - xscheme-process-filter:simple-action)) - "Table used to decide how to handle process filter commands. -Value is a list of entries, each entry is a list of three items. - -The first item is the character that the process filter dispatches on. -The second item is the action to be taken, a function. -The third item is the handler for the entry, a function. - -When the process filter sees a command whose character matches a -particular entry, it calls the handler with two arguments: the action -and the string containing the rest of the process filter's input -stream. It is the responsibility of the handler to invoke the action -with the appropriate arguments, and to reenter the process filter with -the remaining input.") - -(defun xscheme-process-filter:simple-action (action) - (setq xscheme-process-filter-state 'idle) - (funcall action)) - -(defun xscheme-process-filter:string-action (action) - (setq xscheme-string-receiver action) - (setq xscheme-string-accumulator "") - (setq xscheme-process-filter-state 'reading-string)) - -(defconst xscheme-runlight:running "run" - "The character displayed when the Scheme process is running.") - -(defconst xscheme-runlight:input "input" - "The character displayed when the Scheme process is waiting for input.") - -(defconst xscheme-runlight:gc "gc" - "The character displayed when the Scheme process is garbage collecting.") - -(defun xscheme-start-gc () - (xscheme-set-runlight xscheme-runlight:gc)) - -(defun xscheme-finish-gc () - (xscheme-set-runlight - (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) - -(defun xscheme-enter-input-wait () - (xscheme-set-runlight xscheme-runlight:input) - (setq xscheme-running-p nil)) - -(defun xscheme-exit-input-wait () - (xscheme-set-runlight xscheme-runlight:running) - (setq xscheme-running-p t)) - -(defun xscheme-enable-control-g () - (setq xscheme-control-g-disabled-p nil)) - -(defun xscheme-display-process-buffer () - (let ((window (or (xscheme-process-buffer-window) - (display-buffer (xscheme-process-buffer))))) - (save-window-excursion - (select-window window) - (xscheme-goto-output-point) - (if (xscheme-debugger-mode-p) - (xscheme-enter-interaction-mode))))) - -(defun xscheme-unsolicited-read-char () - nil) - -(defun xscheme-eval (string) - (eval (car (read-from-string string)))) - -(defun xscheme-message (string) - (if (not (zerop (length string))) - (xscheme-write-message-1 string (format ";%s" string)))) - -(defun xscheme-write-value (string) - (if (zerop (length string)) - (xscheme-write-message-1 "(no value)" ";No value") - (xscheme-write-message-1 string (format ";Value: %s" string)))) - -(defun xscheme-write-message-1 (message-string output-string) - (let* ((process (get-process "scheme")) - (window (get-buffer-window (process-buffer process)))) - (if (or (not window) - (not (pos-visible-in-window-p (process-mark process) - window))) - (message "%s" message-string))) - (xscheme-guarantee-newlines 1) - (xscheme-process-filter-output output-string)) - -(defun xscheme-set-prompt-variable (string) - (setq xscheme-prompt string)) - -(defun xscheme-set-prompt (string) - (setq xscheme-prompt string) - (xscheme-guarantee-newlines 2) - (setq xscheme-mode-string (xscheme-coerce-prompt string)) - (force-mode-line-update t)) - -(defun xscheme-output-goto () - (xscheme-goto-output-point) - (xscheme-guarantee-newlines 2)) - -(defun xscheme-coerce-prompt (string) - (if (string-match "^[0-9]+ " string) - (let ((end (match-end 0))) - (concat (substring string 0 end) - (let ((prompt (substring string end))) - (let ((entry (assoc prompt xscheme-prompt-alist))) - (if entry - (cdr entry) - prompt))))) - string)) - -(defvar xscheme-prompt-alist - '(("[Normal REPL]" . "[Evaluator]") - ("[Error REPL]" . "[Evaluator]") - ("[Breakpoint REPL]" . "[Evaluator]") - ("[Debugger REPL]" . "[Evaluator]") - ("[Visiting environment]" . "[Evaluator]") - ("[Environment Inspector]" . "[Where]")) - "An alist which maps the Scheme command interpreter type to a print string.") - -(defun xscheme-cd (directory-string) - (save-excursion - (set-buffer (xscheme-process-buffer)) - (cd directory-string))) - -(defun xscheme-prompt-for-confirmation (prompt-string) - (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n))) - -(defun xscheme-prompt-for-expression (prompt-string) - (xscheme-send-string-2 - (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map))) - -(defvar xscheme-prompt-for-expression-map nil) -(if (not xscheme-prompt-for-expression-map) - (progn - (setq xscheme-prompt-for-expression-map - (copy-keymap minibuffer-local-map)) - (substitute-key-definition 'exit-minibuffer - 'xscheme-prompt-for-expression-exit - xscheme-prompt-for-expression-map))) - -(defun xscheme-prompt-for-expression-exit () - (interactive) - (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one) - (exit-minibuffer) - (error "input must be a single, complete expression"))) - -(defun xscheme-region-expression-p (start end) - (save-excursion - (let ((old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table scheme-mode-syntax-table) - (let ((state (parse-partial-sexp start end))) - (and (zerop (car state)) ;depth = 0 - (nth 2 state) ;last-sexp exists, i.e. >= 1 sexps - (let ((state (parse-partial-sexp start (nth 2 state)))) - (if (nth 2 state) 'many 'one))))) - (set-syntax-table old-syntax-table))))) - -(provide 'xscheme) - -;;; xscheme.el ends here rmfile ./site-lisp/guileint-1.5/xscheme.el hunk ./site-lisp/thumbs.el 1 -;;; thumbs.el --- Thumbnails previewer for images files -;;; -;; Author: Jean-Philippe Theberge -;; -;; Thanks: Alex Schroeder for maintaining the package at some time -;; The peoples at #emacs@freenode.net for numerous help -;; RMS for emacs and the GNU project. -;; -;; Keywords: Multimedia -;; Compatibility: Emacs 21 and up. -;; Incompatibility: Emacs < 21 -(defconst thumbs-version "2.0") -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Commentary: - -;; This package create two new mode: thumbs-mode and -;; thumbs-view-image-mode. It is used for images browsing and viewing -;; from within emacs. Minimal image manipulation functions are also -;; available via external programs. -;; -;; The 'convert' program from 'ImageMagick' -;; [URL:http://www.imagemagick.org/] is required. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; CHANGELOG -;; -;; This is version 2.0 -;; -;; USAGE -;; -;; Type M-x thumbs RET DIR RET to view the directory DIR in Thumbs mode. -;; That should be a directory containing image files. -;; from dired, C-t m enter in thumbs-mode with all marked files -;; C-t a enter in thumbs-mode with all files in current-directory -;; In thumbs-mode, pressing on a image will bring you in image view mode -;; for that image. C-h m will give you a list of available keybinding. - -;;; History: -;; - -;;; Code: - -(require 'dired) - -;; Abort if in-line imaging isn't supported (i.e. Emacs-20.7) - -(when (not (display-images-p)) - (error "Your Emacs version (%S) doesn't support in-line images, -was not compiled with image support or is run in console mode. -Upgrade to Emacs 21.1 or newer, compile it with image support -or use a window-system" - emacs-version)) - -;; CUSTOMIZATIONS - -(defgroup thumbs nil - "Thumbnails previewer." - :group 'multimedia) - -(defcustom thumbs-thumbsdir - (expand-file-name "~/.emacs-thumbs") - "*Directory to store thumbnails." - :type 'directory - :group 'thumbs) - -(defcustom thumbs-geometry "100x100" - "*Size of thumbnails." - :type 'string - :group 'thumbs) - -(defcustom thumbs-per-line 5 - "*Number of thumbnails per line to show in directory." - :type 'string - :group 'thumbs) - -(defcustom thumbs-thumbsdir-max-size 50000000 - "Max size for thumbnails directory. -When it reach that size (in bytes), a warning is send." - :type 'string - :group 'thumbs) - -(defcustom thumbs-conversion-program - (if (equal 'windows-nt system-type) - "convert.exe" - (or (executable-find "convert") - "/usr/X11R6/bin/convert")) - "*Name of conversion program for thumbnails generation. -It must be 'convert'." - :type 'string - :group 'thumbs) - -(defcustom thumbs-setroot-command - "xloadimage -onroot -fullscreen *" - "Command to set the root window." - :type 'string - :group 'thumbs) - -(defcustom thumbs-relief 5 - "*Size of button-like border around thumbnails." - :type 'string - :group 'thumbs) - -(defcustom thumbs-margin 2 - "*Size of the margin around thumbnails. -This is where you see the cursor." - :type 'string - :group 'thumbs) - -(defcustom thumbs-thumbsdir-auto-clean t - "If set, delete older file in the thumbnails directory. -Deletion is done at load time when the directory size is bigger -than 'thumbs-thumbsdir-max-size'." - :type 'boolean - :group 'thumbs) - -(defcustom thumbs-image-resizing-step 10 - "Step by wich to resize image." - :type 'string - :group 'thumbs) - -(defcustom thumbs-temp-dir - "/tmp/" - "Temporary directory to use. -Leaving it to default '/tmp/' can let another user -see some of your images." - :type 'directory - :group 'thumbs) - -(defcustom thumbs-temp-prefix "emacsthumbs" - "Prefix to add to temp files." - :type 'string - :group 'thumbs) - -;; Initialize some variable, for later use. -(defvar thumbs-temp-file - (concat thumbs-temp-dir thumbs-temp-prefix) - "Temporary filesname for images.") - -(defvar thumbs-current-tmp-filename - nil - "Temporary filename of current image.") -(defvar thumbs-current-image-filename - nil - "Filename of current image.") -(defvar thumbs-current-image-size - nil - "Size of current image.") -(defvar thumbs-image-num - nil - "Number of current image.") -(defvar thumbs-current-dir - nil - "Current directory.") -(defvar thumbs-markedL - nil - "List of marked files.") - -;; Make sure auto-image-file-mode is ON. -(auto-image-file-mode t) - -;; Create the thumbs directory if it does not exists. -(setq thumbs-thumbsdir (expand-file-name thumbs-thumbsdir)) - -(when (not (file-directory-p thumbs-thumbsdir)) - (progn - (make-directory thumbs-thumbsdir) - (message "Creating thumbnails directory"))) - -(when (not (fboundp 'ignore-errors)) - (defmacro ignore-errors (&rest body) - "Execute FORMS; if anz error occurs, return nil. -Otherwise, return result of last FORM." - (let ((err (thumbs-gensym))) - (list 'condition-case err (cons 'progn body) '(error nil))))) - -(when (not (fboundp 'time-less-p)) - (defun time-less-p (t1 t2) - "Say whether time T1 is less than time T2." - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2)))))) - -(when (not (fboundp 'caddar)) - (defun caddar (x) - "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (car (cdr (cdr (car x)))))) - -(defvar thumbs-gensym-counter 0) - -(defun thumbs-gensym (&optional arg) - "Generate a new uninterned symbol. -The name is made by appending a number to PREFIX, default \"Thumbs\"." - (let ((prefix (if (stringp arg) arg "Thumbs")) - (num (if (integerp arg) arg - (prog1 - thumbs-gensym-counter - (setq thumbs-gensym-counter (1+ thumbs-gensym-counter)))))) - (make-symbol (format "%s%d" prefix num)))) - -(defun thumbs-cleanup-thumbsdir () - "Clean the thumbnails directory. -If the total size of all files in 'thumbs-thumbsdir' is bigger than -'thumbs-thumbsdir-max-size', files are deleted until the max size is -reached." - (let* ((filesL - (sort - (mapcar - (lambda (f) - (let ((fattribsL (file-attributes f))) - `(,(nth 4 fattribsL) ,(nth 7 fattribsL) ,f))) - (directory-files thumbs-thumbsdir t (image-file-name-regexp))) - '(lambda (l1 l2) (time-less-p (car l1)(car l2))))) - (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL)))) - (while (> dirsize thumbs-thumbsdir-max-size) - (progn - (message "Deleting file %s" (caddar filesL))) - (delete-file (caddar filesL)) - (setq dirsize (- dirsize (cadar filesL))) - (setq filesL (cdr filesL))))) - -;; Check the thumbsnail directory size and clean it if necessary. -(when thumbs-thumbsdir-auto-clean - (thumbs-cleanup-thumbsdir)) - -(defun thumbs-call-convert (filein fileout action - &optional arg output-format action-prefix) - "Call the convert program. -FILEIN is the input file, -FILEOUT is the output file, -ACTION is the command to send to convert. -Optional argument are: -ARG any arguments to the ACTION command, -OUTPUT-FORMAT is the file format to output, default is jpeg -ACTION-PREFIX is the symbol to place before the ACTION command - (default to '-' but can sometime be '+')." - (let ((command (format "%s %s%s %s \"%s\" \"%s:%s\"" - thumbs-conversion-program - (or action-prefix "-") - action - (or arg "") - filein - (or output-format "jpeg") - fileout))) - (shell-command command))) - -(defun thumbs-increment-image-size-element (n d) - "Increment number N by D percent." - (round (+ n (/ (* d n) 100)))) - -(defun thumbs-decrement-image-size-element (n d) - "Decrement number N by D percent." - (round (- n (/ (* d n) 100)))) - -(defun thumbs-increment-image-size (s) - "Increment S (a cons of width x heigh)." - (cons - (thumbs-increment-image-size-element (car s) - thumbs-image-resizing-step) - (thumbs-increment-image-size-element (cdr s) - thumbs-image-resizing-step))) - -(defun thumbs-decrement-image-size (s) - "Decrement S (a cons of width x heigh)." - (cons - (thumbs-decrement-image-size-element (car s) - thumbs-image-resizing-step) - (thumbs-decrement-image-size-element (cdr s) - thumbs-image-resizing-step))) - -(defun thumbs-resize-image (&optional increment size) - "Resize image in current buffer. -if INCREMENT is set, make the image bigger, else smaller. -Or, alternatively, a SIZE may be specified." - (interactive) - ;; cleaning of old temp file - (ignore-errors - (apply 'delete-file - (directory-files - thumbs-temp-dir t - thumbs-temp-prefix))) - (let ((buffer-read-only nil) - (x (if size - size - (if increment - (thumbs-increment-image-size - thumbs-current-image-size) - (thumbs-decrement-image-size - thumbs-current-image-size)))) - (tmp (format "%s%s.jpg" thumbs-temp-file (thumbs-gensym)))) - (erase-buffer) - (thumbs-call-convert thumbs-current-image-filename - tmp "sample" - (concat (number-to-string (car x)) "x" - (number-to-string (cdr x)))) - (thumbs-insert-image tmp 'jpeg 0) - (setq thumbs-current-tmp-filename tmp))) - -(defun thumbs-resize-interactive (width height) - "Resize Image interactively to specified WIDTH and HEIGHT." - (interactive "nWidth: \nnHeight: ") - (thumbs-resize-image nil (cons width height))) - -(defun thumbs-resize-image-size-down () - "Resize image (smaller)." - (interactive) - (thumbs-resize-image nil)) - -(defun thumbs-resize-image-size-up () - "Resize image (bigger)." - (interactive) - (thumbs-resize-image t)) - -(defun thumbs-subst-char-in-string (orig rep string) - "Replace occurrences of character ORIG with character REP in STRING. -Return the resulting (new) string. -- (defun borowed to Dave Love)" - (let ((string (copy-sequence string)) - (l (length string)) - (i 0)) - (while (< i l) - (if (= (aref string i) orig) - (aset string i rep)) - (setq i (1+ i))) - string)) - -(defun thumbs-thumbname (img) - "Return a thumbnail name for the image IMG." - (concat thumbs-thumbsdir "/" - (thumbs-subst-char-in-string - ?\ ?\_ - (apply - 'concat - (split-string - (expand-file-name img) "/"))))) - -(defun thumbs-make-thumb (img) - "Create the thumbnail for IMG." - (let* ((fn (expand-file-name img)) - (tn (thumbs-thumbname img))) - (if (or (not (file-exists-p tn)) - (not (equal (thumbs-file-size tn) thumbs-geometry))) - (thumbs-call-convert fn tn "sample" thumbs-geometry)) - tn)) - -(defun thumbs-image-type (img) - "Return image type from filename IMG." - (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg) - ((string-match ".*\\.xpm\\'" img) 'xpm) - ((string-match ".*\\.xbm\\'" img) 'xbm) - ((string-match ".*\\.gif\\'" img) 'gif) - ((string-match ".*\\.bmp\\'" img) 'bmp) - ((string-match ".*\\.png\\'" img) 'png) - ((string-match ".*\\.tiff?\\'" img) 'tiff))) - -(defun thumbs-file-size (img) - (let ((i (image-size (find-image `((:type ,(thumbs-image-type img) :file ,img))) t))) - (concat (number-to-string (round (car i))) - "x" - (number-to-string (round (cdr i)))))) - -;;;###autoload -(defun thumbs-find-thumb (img) - "Display the thumbnail for IMG." - (interactive "f") - (find-file (thumbs-make-thumb img))) - -(defun thumbs-insert-image (img type relief &optional marked) - "Insert image IMG at point. -TYPE and RELIEF will be used in constructing the image; see `image' -in the emacs-lisp manual for further documentation. -if MARKED is non-nil, the image is marked." - (let ((i `(image :type ,type - :file ,img - :relief ,relief - :conversion ,(if marked 'disabled) - :margin ,thumbs-margin))) - (insert-image i) - (setq thumbs-current-image-size - (image-size i t)))) - -(defun thumbs-insert-thumb (img &optional marked) - "Insert the thumbnail for IMG at point. -if MARKED is non-nil, the image is marked" - (thumbs-insert-image - (thumbs-make-thumb img) 'jpeg thumbs-relief marked)) - -(defun thumbs-do-thumbs-insertion (L) - "Insert all thumbs in list L." - (setq thumbs-fileL nil) - (let ((i 0)) - (while L - (when (= 0 (mod (setq i (1+ i)) thumbs-per-line)) - (newline)) - (setq thumbs-fileL (cons (cons (point) - (car L)) - thumbs-fileL)) - (thumbs-insert-thumb (car L) - (member (car L) thumbs-markedL)) - (setq L (cdr L))))) - -(defun thumbs-show-thumbs-list (L &optional buffer-name same-window) - (funcall (if same-window 'switch-to-buffer 'pop-to-buffer) - (or buffer-name "*THUMB-View*")) - (let ((inhibit-read-only t)) - (erase-buffer) - (thumbs-mode) - (make-variable-buffer-local 'thumbs-fileL) - (setq thumbs-fileL nil) - (thumbs-do-thumbs-insertion L) - (goto-char (point-min)) - (setq thumbs-current-dir default-directory) - (make-variable-buffer-local 'thumbs-current-dir))) - -;;;###autoload -(defun thumbs-show-all-from-dir (dir &optional reg same-window) - "Make a preview buffer for all images in DIR. -Optional argument REG to select file matching a regexp, -and SAME-WINDOW to show thumbs in the same window." - (interactive "DDir: ") - (thumbs-show-thumbs-list - (directory-files dir t - (or reg (image-file-name-regexp))) - (concat "*Thumbs: " dir) same-window)) - -;;;###autoload -(defun thumbs-dired-show-marked () - "In Dired, make a thumbs buffer with all marked files." - (interactive) - (thumbs-show-thumbs-list (dired-get-marked-files) nil t)) - -;;;###autoload -(defun thumbs-dired-show-all () - "In dired, make a thumbs buffer with all files in current directory." - (interactive) - (thumbs-show-all-from-dir default-directory nil t)) - -;;;###autoload -(defalias 'thumbs 'thumbs-show-all-from-dir) - -(defun thumbs-find-image (img L &optional num otherwin) - (funcall - (if otherwin 'switch-to-buffer-other-window 'switch-to-buffer) - (concat "*Image: " (file-name-nondirectory img) " - " - (number-to-string (or num 0)) "*")) - (thumbs-view-image-mode) - (let ((inhibit-read-only t)) - (setq thumbs-current-image-filename img - thumbs-current-tmp-filename nil - thumbs-image-num (or num 0)) - (make-variable-buffer-local 'thumbs-current-image-filename) - (make-variable-buffer-local 'thumbs-current-tmp-filename) - (make-variable-buffer-local 'thumbs-current-image-size) - (make-variable-buffer-local 'thumbs-image-num) - (make-variable-buffer-local 'thumbs-fileL) - (setq thumbs-fileL L) - (delete-region (point-min)(point-max)) - (thumbs-insert-image img (thumbs-image-type img) 0))) - -(defun thumbs-find-image-at-point (&optional img otherwin) - "Display image IMG for thumbnail at point. -use another window it OTHERWIN is t." - (interactive) - (let* ((L thumbs-fileL) - (n (point)) - (i (or img (cdr (assoc n L))))) - (thumbs-find-image i L n otherwin))) - -(defun thumbs-find-image-at-point-other-window () - "Display image for thumbnail at point in the preview buffer. -Open another window." - (interactive) - (thumbs-find-image-at-point nil t)) - -(defun thumbs-call-setroot-command (img) - "Call the setroot program for IMG." - (run-hooks 'thumbs-before-setroot-hook) - (shell-command (replace-regexp-in-string - "\\*" - (shell-quote-argument (expand-file-name img)) - thumbs-setroot-command nil t)) - (run-hooks 'thumbs-after-setroot-hook)) - -(defun thumbs-set-image-at-point-to-root-window () - "Set the image at point as the desktop wallpaper." - (interactive) - (thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL)))) - -(defun thumbs-set-root () - "Set the current image as root." - (interactive) - (thumbs-call-setroot-command - (or thumbs-current-tmp-filename - thumbs-current-image-filename))) - -(defun thumbs-delete-images () - "Delete the image at point (and it's thumbnail) (or marked files if any)." - (interactive) - (let ((f (or thumbs-markedL (list (cdr (assoc (point) thumbs-fileL)))))) - (if (yes-or-no-p "Really delete %d files?" (length f)) - (progn - (mapcar (lambda (x) - (setq thumbs-fileL (delete (rassoc x thumbs-fileL) thumbs-fileL)) - (delete-file x) - (delete-file (thumbs-thumbname x))) f) - (thumbs-redraw-buffer))))) - -(defun thumbs-kill-buffer () - "Kill the current buffer." - (interactive) - (let ((buffer (current-buffer))) - (ignore-errors (delete-window (selected-window))) - (kill-buffer buffer))) - -(defun thumbs-show-image-num (num) - "Show the image with number NUM." - (let ((inhibit-read-only t)) - (delete-region (point-min)(point-max)) - (let ((i (cdr (assoc num thumbs-fileL)))) - (thumbs-insert-image i (thumbs-image-type i) 0) - (sleep-for 2) - (rename-buffer (concat "*Image: " - (file-name-nondirectory i) - " - " - (number-to-string num) "*"))) - (setq thumbs-image-num num - thumbs-current-image-filename i))) - -(defun thumbs-next-image () - "Show next image." - (interactive) - (let* ((i (1+ thumbs-image-num)) - (l (caar thumbs-fileL)) - (num - (cond ((assoc i thumbs-fileL) i) - ((>= i l) 1) - (t (1+ i))))) - (thumbs-show-image-num num))) - -(defun thumbs-previous-image () - "Show the previous image." - (interactive) - (let* ((i (- thumbs-image-num 1)) - (l (caar thumbs-fileL)) - (num - (cond ((assoc i thumbs-fileL) i) - ((<= i 1) l) - (t (- i 1))))) - (thumbs-show-image-num num))) - -(defun thumbs-redraw-buffer () - "Redraw the current thumbs buffer." - (let ((p (point)) - (inhibit-read-only t)) - (delete-region (point-min)(point-max)) - (thumbs-do-thumbs-insertion (reverse (mapcar 'cdr thumbs-fileL))) - (goto-char (1+ p)))) - -(defun thumbs-mark () - "Mark the image at point." - (interactive) - (setq thumbs-markedL (cons (cdr (assoc (point) thumbs-fileL)) thumbs-markedL)) - (let ((inhibit-read-only t)) - (delete-char 1) - (thumbs-insert-thumb (cdr (assoc (point) thumbs-fileL)) t)) - (when (eolp)(forward-char))) - -;; Image modification routines - -(defun thumbs-modify-image (action &optional arg) - "Call convert to do ACTION on image with argument ARG. -ACTION and ARG should be legal convert command." - (interactive "sAction: \nsValue: ") - ;; cleaning of old temp file - (mapc 'delete-file - (directory-files - thumbs-temp-dir - t - thumbs-temp-prefix)) - (let ((buffer-read-only nil) - (tmp (format "%s%s.jpg" thumbs-temp-file (thumbs-gensym)))) - (erase-buffer) - (thumbs-call-convert thumbs-current-image-filename - tmp - action - (or arg "")) - (thumbs-insert-image tmp 'jpeg 0) - (setq thumbs-current-tmp-filename tmp))) - -(defun thumbs-emboss-image (emboss) - "Emboss the image with value EMBOSS." - (interactive "nEmboss value: ") - (if (or (< emboss 3)(> emboss 31)(evenp emboss)) - (error "Arg must be a odd number between 3 and 31")) - (thumbs-modify-image "emboss" (number-to-string emboss))) - -(defun thumbs-monochrome-image () - "Turn the image to monochrome." - (interactive) - (thumbs-modify-image "monochrome")) - -(defun thumbs-negate-image () - "Negate the image." - (interactive) - (thumbs-modify-image "negate")) - -(defun thumbs-rotate-left () - "Rotate the image 90 degrees counter-clockwise." - (interactive) - (thumbs-modify-image "rotate" "270")) - -(defun thumbs-rotate-right () - "Rotate the image 90 degrees clockwise." - (interactive) - (thumbs-modify-image "rotate" "90")) - -(defun thumbs-forward-char () - "Move forward one image." - (interactive) - (forward-char) - (when (eolp)(forward-char)) - (thumbs-show-name)) - -(defun thumbs-backward-char () - "Move backward one image." - (interactive) - (forward-char -1) - (thumbs-show-name)) - -(defun thumbs-forward-line () - "Move down one line." - (interactive) - (forward-line 1) - (thumbs-show-name)) - -(defun thumbs-backward-line () - "Move up one line." - (interactive) - (forward-line -1) - (thumbs-show-name)) - -(defun thumbs-show-name () - "Show the name of the current file." - (interactive) - (let ((f (cdr (assoc (point) thumbs-fileL)))) - (message "%s [%s]" f (thumbs-file-size f)))) - -(defun thumbs-save-current-image () - "Save the current image." - (interactive) - (let ((f (or thumbs-current-tmp-filename - thumbs-current-image-filename)) - (sa (read-from-minibuffer "save file as: " - thumbs-current-image-filename))) - (copy-file f sa))) - -(defun thumbs-dired () - "Use `dired' on the current thumbs directory." - (interactive) - (dired thumbs-current-dir)) - -;; thumbs-mode - -(defvar thumbs-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [return] 'thumbs-find-image-at-point) - (define-key map [(meta return)] 'thumbs-find-image-at-point-other-window) - (define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window) - (define-key map [delete] 'thumbs-delete-images) - (define-key map [right] 'thumbs-forward-char) - (define-key map [left] 'thumbs-backward-char) - (define-key map [up] 'thumbs-backward-line) - (define-key map [down] 'thumbs-forward-line) - (define-key map "d" 'thumbs-dired) - (define-key map "m" 'thumbs-mark) - (define-key map "s" 'thumbs-show-name) - (define-key map "q" 'thumbs-kill-buffer) - map) - "Keymap for `thumbs-mode'.") - -(define-derived-mode thumbs-mode - fundamental-mode "thumbs" - "Preview images in a thumbnails buffer" - (make-variable-buffer-local 'thumbs-markedL) - (setq thumbs-markedL nil)) - -(defvar thumbs-view-image-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [prior] 'thumbs-previous-image) - (define-key map [next] 'thumbs-next-image) - (define-key map "-" 'thumbs-resize-image-size-down) - (define-key map "+" 'thumbs-resize-image-size-up) - (define-key map "<" 'thumbs-rotate-left) - (define-key map ">" 'thumbs-rotate-right) - (define-key map "e" 'thumbs-emboss-image) - (define-key map "r" 'thumbs-resize-interactive) - (define-key map "s" 'thumbs-save-current-image) - (define-key map "q" 'thumbs-kill-buffer) - (define-key map "w" 'thunbs-set-root) - map) - "Keymap for `thumbs-view-image-mode'.") - -;; thumbs-view-image-mode -(define-derived-mode thumbs-view-image-mode - fundamental-mode "image-view-mode") - -;;;###autoload -(defun thumbs-dired-setroot () - "In dired, Call the setroot program on the image at point." - (interactive) - (thumbs-call-setroot-command (dired-get-filename))) - -;; Modif to dired mode map -(define-key dired-mode-map "\C-ta" 'thumbs-dired-show-all) -(define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked) -(define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) - -(provide 'thumbs) - -;;; thumbs.el ends here - rmfile ./site-lisp/thumbs.el hunk ./site-lisp/vc-darcs.el 1 -;;; vc-darcs.el --- a VC backend for darcs - -;;; Copyright (C) 2004 Jorgen Schaefer -;;; Copyright (C) 2004-2006 Juliusz Chroboczek - -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License -;;; as published by the Free Software Foundation; either version 2 -;;; of the License, or (at your option) any later version. - -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. - -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. - -;;; Commentary: - -;; Darcs is David's Advanced Revision Control System at -;; http://www.darcs.net/ - -;; A few ideas for this file are directly taken from vc-svn.el. Thanks -;; to Jim Blandy. - -;; To install, put this file into your load-path and add the following -;; to your .emacs: - -;; (add-to-list 'vc-handled-backends 'DARCS) -;; (autoload 'vc-darcs-find-file-hook "vc-darcs") -;; (add-hook 'find-file-hooks 'vc-darcs-find-file-hook) - -;; There are a few reasons why vc is difficult to coerce into using -;; darcs as a backend. Vc expects files (not trees) to be versioned -;; as nodes in an AND/OR tree, as is done by RCS and CVS. This -;; expectation is hardwired throughout vc, notably in VC-PREVIOUS-VERSION. - -;; Subversion versions trees (not files) as integers, which sort of -;; works with vc, although things like VC-DIFF might produce -;; unexpected results (most of the time, the right ``previous -;; version'' of file foo~42~ is not foo~41~ but some earlier version). - -;; Darcs doesn't version files at all; a darcs repository is a -;; collection of patches, and a particular file version is just the -;; set of patches that have been applied in order to build it. While -;; patches might be reordered when moving them between repositories, -;; they usually remain ordered (notable exceptions to that being -;; unpull and, someday, optimize); hence, a convenient mental shortcut -;; is to identify a version by the latest patch included in that -;; version. This is what we do. - -;; Internally, darcs identifies a patch by its hash, which you may -;; obtain by using changes --xml. We follow that approach in this -;; code. However, as a hash might be difficult to remember at times -;; (it's 65 characters long), all commands that might take an interac- -;; tive argument also accept a regexp identifying a patch name. See -;; VC-DARCS-REV-TO-HASH. - -;; The fit with vc is not perfect, and there are a number of -;; limitations. One is that VC-PREVIOUS-VERSION cannot be customised -;; by a backend, and it doesn't take a file as argument; hence, it -;; doesn't do anything useful with darcs. Another is that vc doesn't -;; normalise versions; hence, if you have a patch called ``Initial -;; import'', you might end up with distinct but identical buffers -;; called vc-darcs.el~Init~, vc-darcs.el~Initial~ and so on. - -(defvar vc-darcs-version-string "1.8jch" - "The version string for vc-darcs.el.") - -;;; Code: - -(eval-when-compile - (require 'xml) - (require 'cl)) - -(require 'xml) -(require 'cl) - -(defgroup vc-darcs nil - "*The darcs backend for vc." - :prefix "vc-darcs-" - :group 'vc) - -(defcustom vc-darcs-program-name "darcs" - "*The name of the darcs command." - :type 'string - :group 'vc-darcs) - -(defcustom vc-darcs-program-arguments '((diff "-u")) - "*An a-list of further arguments to pass to darcs. -Each element consists of a symbol naming the command to work on, and a -list of arguments to pass." - :type '(alist :key-type symbol :value-type (list string)) - :group 'vc-darcs) - -(defcustom vc-darcs-mail-address - (or (getenv "DARCS_EMAIL") - (getenv "EMAIL") - (if (string-match "<" user-mail-address) - user-mail-address - (format "%s <%s>" - (user-full-name) user-mail-address))) - "*The email address to use in darcs." - :type '(choice string (const nil)) - :group 'vc-darcs) - -(defcustom vc-darcs-full-log nil - "*Whether vc-print-log on a file recorded by darcs prints a full log -or only a log for the current file." - :type 'boolean - :group 'vc-darcs) - -(defcustom vc-darcs-trust-file-times t - "*Whether to trust filesystem times when determining the state of a file. -If this is non-nil, vc will consider that a file is up-to-date if its -modification time matches the one of the pristine file. This may -speed some operations quite a bit, but is potentially unsafe, -especially on non-POSIX filesystems (e.g. vfat). - -If you set this, you probably also want to set - - ALL ignore-times - -in your Darcs preferences." - :type 'boolean - :group 'vc-darcs) - -(defun vc-darcs-root-directory (file) - "Return the root darcs repository directory for FILE, or nil if -there is none." - (let ((dir (file-name-directory (expand-file-name file))) - (olddir "/")) - (while (and (not (equal dir olddir)) - (not (file-directory-p (concat dir "/_darcs")))) - (setq olddir dir - dir (file-name-directory (directory-file-name dir)))) - (and (not (equal dir olddir)) dir))) - -(defun vc-darcs-darcs-directory (file) - "Return the darcs directory for FILE, or nil if there is none." - (let ((dir (vc-darcs-root-directory file))) - (and dir (concat dir "_darcs/")))) - -(defun vc-darcs-pristine-directory (root) - "Return the pristine directory of repository ROOT." - (let* ((root (if (eq ?/ (aref root (- (length root) 1))) - root - (concat root "/"))) - (pristine (concat root "_darcs/pristine/")) - (current (concat root "_darcs/current/"))) - (or - (and (file-directory-p pristine) pristine) - (and (file-directory-p current) current)))) - -(defun vc-darcs-pristine-file (file) - "Return the pristine file corresponding to FILE." - (let* ((root (vc-darcs-root-directory file)) - (pristine (and root (vc-darcs-pristine-directory root)))) - (when (and root pristine - (string-match (concat "^" (regexp-quote root) "\\(.*\\)") file)) - (concat pristine (match-string 1 file))))) - -(defun vc-darcs-do-command (command okstatus file &rest flags) - "Run darcs COMMAND using `vc-do-command', passing OKSTATUS and FILE -along with FLAGS." - (let ((arguments (cdr (assq command vc-darcs-program-arguments)))) - (apply #'vc-do-command nil okstatus - vc-darcs-program-name file (symbol-name command) - (append arguments flags)))) - -(defun vc-darcs-report-error () - "Report a darcs error in the current buffer." - (goto-char (point-max)) - (let ((found (search-backward "Fail:" nil t))) - (if found - (error (buffer-substring found (point-max))) - (error (buffer-substring (max 0 (- (point-max) 1000)) - (point-max)))))) - -(defmacro vc-darcs-with-error-reporting (&rest body) - (list 'condition-case 'nil - (if (null (cdr body)) (car body) (cons 'progn body)) - '(vc-darcs-report-error))) - -(defun vc-darcs-changes (&optional file &rest flags) - "Return a list of hashes of the patches that touch FILE in inverse order." - (with-temp-buffer - (apply #'vc-do-command t nil vc-darcs-program-name - (and file (file-name-nondirectory file)) - "changes" "--xml" flags) - (let ((changes (xml-parse-region 1 (point-max)))) - (unless (and (null (cdr changes)) - (eq 'changelog (car (car changes)))) - (error "Unexpected output from darcs changes --xml.")) - (mapcon #'(lambda (e) - (and (consp (car e)) - (eq (caar e) 'patch) - (let ((h (cdr (assoc 'hash (cadar e))))) - (and h (list (substring h 0 61)))))) - (cddr (car changes)))))) - -(defun vc-darcs-hash-p (rev) - "Return non-nil if REV has the syntax of a darcs hash." - (and (= (length rev) 61) - (eq (aref rev 14) ?-) - (eq (aref rev 20) ?-) - (string-match "[a-z0-9-]" rev) - t)) - -(defun vc-darcs-rev-to-hash (rev file &optional off-by-one) - (cond - ((null rev) nil) - ((not off-by-one) - (cond - ((vc-darcs-hash-p rev) rev) - (t (car (last (vc-darcs-changes file "--patch" rev)))))) - (t - (let ((flags - (if (vc-darcs-hash-p rev) - (list "--from-match" (concat "hash " rev)) - (list "--from-patch" rev)))) - (let ((changes (apply #'vc-darcs-changes file flags))) - (and (cdr changes) (car (last changes 2)))))))) - -(defun vc-darcs-registered (file) - "Return non-nil if FILE is handled by darcs. -This is either the case if this file is in the pristine tree, or -if the addition of this file is in pending." - (let ((pristine (vc-darcs-pristine-file file))) - (or (and pristine (file-exists-p pristine)) - (let* ((root (vc-darcs-root-directory file)) - (pending (concat root "_darcs/patches/pending")) - (relative (concat "./" (substring file (length root)))) - (addfile (concat "^addfile " (regexp-quote relative)))) - (when (file-exists-p pending) - (with-temp-buffer - (insert-file-contents pending) - (re-search-forward addfile nil t))))))) - -(defun vc-darcs-file-times-equal-p (file1 file2) - (equal (nth 5 (file-attributes file1)) (nth 5 (file-attributes file2)))) - -(defun vc-darcs-state (file) - "Return the state of FILE." - (cond - ((and vc-darcs-trust-file-times - (vc-darcs-file-times-equal-p - file (vc-darcs-pristine-file file))) - 'up-to-date) - (t - (with-temp-buffer - (vc-do-command t nil vc-darcs-program-name - (file-name-nondirectory file) - "whatsnew" "--summary") - (goto-char (point-max)) - (previous-line 1) - (if (looking-at "^No changes!") - 'up-to-date - 'edited))))) - -(defun vc-darcs-checkout-model (file) - "Indicate how FILE is checked out. This is always IMPLICIT with darcs." - 'implicit) - -(defun vc-darcs-responsible-p (file) - "Return non-nil if we feel responsible for FILE, which can also be a -directory." - (and (vc-darcs-root-directory file) t)) - -(defun vc-darcs-workfile-version (file) - "Return the current working-dir version of FILE. -With darcs, this is simply the hash of the last patch that touched this file." - (car (vc-darcs-changes file))) - -(defun vc-darcs-workfile-unchanged-p (file) - "Return non-nil if FILE is unchanged from the repository version." - (eq 'up-to-date (vc-darcs-state file))) - -(defun vc-darcs-mode-line-string (file) - "Return the mode line string to show for FILE." - (format "darcs/%s" (vc-state file))) - -(defun vc-darcs-register (file &optional rev comment) - "Add FILE to the darcs repository, and record this. - REV must be NIL, COMMENT is ignored." - (when (not (null rev)) - (error "Cannot specify register revision with darcs.")) - (vc-darcs-do-command 'add 0 file (file-name-nondirectory file))) - -(defun vc-darcs-checkin (file rev comment) - "Record FILE to darcs. REV should always be nil and is ignored, -COMMENT is the new comment." - (when (not (null rev)) - (error "Cannot specify checkin revision with darcs.")) - (let* ((date (format-time-string "%Y%m%d%H%M%S" nil t)) - (match (string-match "\n" comment)) - (patch-name (if match - (substring comment 0 (match-beginning 0)) - comment)) - (log (if match - (substring comment (match-end 0)) - ""))) - (vc-darcs-do-command 'record 'async nil - "-a" "--pipe" (file-name-nondirectory file)) - (with-current-buffer (get-buffer "*vc*") - (process-send-string nil - (format "%s\n%s\n%s\n%s" - date vc-darcs-mail-address patch-name log)) - (process-send-eof)))) - -(defun vc-darcs-checkout (file &optional editable rev destfile) - "This gets revision REV of FILE from the darcs repository. -EDITABLE is ignored." - (let ((rev (vc-darcs-rev-to-hash rev file t)) - (destfile (or destfile file))) - (cond - ((or (not rev) (equal rev (vc-darcs-workfile-version file))) - (copy-file (vc-darcs-pristine-file file) destfile t)) - (t - ;; darcs does not currently allow getting an old version of a - ;; file. We kludge around this by getting the pristine version and - ;; reverting the right patch. - (let ((temp (make-temp-file "vc-darcs"))) - (copy-file (vc-darcs-pristine-file file) temp t) - (with-temp-buffer - (vc-do-command t nil vc-darcs-program-name - (file-name-nondirectory file) - "diff" "-u" - "--from-match" (concat "hash " rev) - "--to-match" - (concat "hash " (vc-darcs-workfile-version file))) - (shell-command-on-region 1 (point-max) - (concat "patch -R " temp) - t)) - (rename-file temp (or destfile file) t)))))) - -(defun vc-darcs-print-log (file) - "Print the logfile for the current darcs repository to the *vc* buffer." - (vc-darcs-do-command 'changes 'async (and (not vc-darcs-full-log) file))) - -(defun vc-darcs-diff (file &optional rev1 rev2) - "Show the differences in FILE between revisions REV1 and REV2." - (let* ((rev1 (vc-darcs-rev-to-hash rev1 file t)) - (rev2 (vc-darcs-rev-to-hash rev2 file)) - (arguments (cdr (assq 'diff vc-darcs-program-arguments))) - (from (and rev1 (list "--from-match" (concat "hash " rev1)))) - (to (and rev2 (list "--to-match" (concat "hash " rev2))))) - (apply #'vc-do-command "*vc-diff*" 'async - vc-darcs-program-name (file-name-nondirectory file) - "diff" - (append from to arguments)))) - -(defun vc-darcs-rename-file (old new) - "Rename the file OLD to NEW in the darcs repository." - (call-process vc-darcs-program-name nil nil nil "mv" old new)) - -(defun vc-darcs-annotate-command (file buffer &optional rev) - (let* ((rev (vc-darcs-rev-to-hash rev file)) - (data - (with-temp-buffer - (apply #'vc-do-command t nil vc-darcs-program-name - (file-name-nondirectory file) - "annotate" "--xml" - (and rev (list "--match" (concat "hash " rev)))) - (let ((output (xml-parse-region 1 (point-max)))) - (unless (and (null (cdr output)) - (eq 'file (car (car output)))) - (error "Unexpected output from darcs annotate --xml.")) - (car output))))) - (with-current-buffer buffer - (let ((modified (assoc 'modified (cddr data)))) - (dolist (e (cddr data)) - (when (and (listp e) - (or (eq 'normal_line (car e)) (eq 'added_line (car e)))) - (let* ((line1 - (find-if - #'(lambda (x) (and (stringp x) (not (equal "\n" x)))) - (cddr e))) - (len (progn (length line1))) - (l0 (if (eq ?\n (aref line1 0)) 1 0)) - (l1 (if (eq ?\n (aref line1 (- len 1))) (- len 1) len)) - (line (substring line1 l0 l1))) - (let* ((added-by (or (assoc 'added_by (cddr e)) modified)) - (patch (assoc 'patch (cddr added-by))) - (rev (substring (cdr (assoc 'hash (cadr patch))) 0 61)) - (author (cdr (assoc 'author (cadr patch)))) - (date (cdr (assoc 'date (cadr patch)))) - (year (substring date 0 4)) - (month (substring date 4 6)) - (day (substring date 6 8)) - (begin (point))) - (insert (format "%-7s %s/%s/%s %s\n" - (if (> (length author) 7) - (substring author 0 7) - author) - day month year - line)))))))))) - -(defun vc-darcs-parse-integer (s) - (let ((value 0) - (index 0) - (len (length s))) - (while (< index len) - (setq value (+ (* 10 value) (- (aref s index) ?0))) - (incf index)) - value)) - -(defun vc-darcs-annotate-time () - (when (looking-at "........[0-9]") - (forward-char 8) - (and - (looking-at "\\(..\\)/\\(..\\)/\\(....\\)") - (let ((day (vc-darcs-parse-integer (match-string 1))) - (month (vc-darcs-parse-integer (match-string 2))) - (year (vc-darcs-parse-integer (match-string 3)))) - (vc-annotate-convert-time - (encode-time 0 0 0 day month year)))))) - -;;; protection against editing files under _darcs -;;; adapted from an idea by Rob Giardine - -(defun vc-darcs-find-file-hook () - (let ((f (buffer-file-name (current-buffer)))) - (and f (string-match "/_darcs" f) (not (string-match "/_darcs/prefs" f)) - (let ((open-instead - (yes-or-no-p - "This is a _darcs file, open the real file instead? "))) - (cond - (open-instead - (let* ((f (buffer-file-name (current-buffer))) - (match - (and f (string-match - "/_darcs/\\(current\\|pristine\\)/" f)))) - (unless match - (error "Couldn't find alternate file name")) - (find-alternate-file - (concat (substring f 0 (match-beginning 0)) - "/" - (substring f (match-end 0)))))) - (t - (setq buffer-read-only t) - (push '(:propertize "_DARCS-FILE:" face font-lock-warning-face) - mode-line-buffer-identification))))))) - -(provide 'vc-darcs) -;;; vc-darcs.el ends here rmfile ./site-lisp/vc-darcs.el hunk ./site-lisp/w3m-session.el 1 -;;; w3m-session.el --- Persistent emacs-w3m sessions - -;; Copyright (C) 2003, 2004, 2006, 2007 Jose A Ortega Ruiz - -;; Author: Jose A Ortega Ruiz -;; Version: 0.3.5 -;; Keywords: hypermedia, w3m, WWW - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; INTRODUCTION: -;; -;; w3m-session provides persistent emacs-w3m browsing sessions. When -;; quitting w3m (or, if you request it, at any other time while using -;; it) you can save the current w3m session (that is, the set of open -;; tabs and the URLs they're visiting). Upon restarting emacs-w3m -;; (possibly after restarting Emacs itself) you'll have the possibity -;; of recovering the saved session (that is, of re-opening the saved -;; tabs and URLs). You also have at your disposal a command to recover -;; the saved session at any other time. -;; -;; INSTALLATION: -;; -;; Just put this file somewhere on your Emacs load path and add the -;; following line to your .emacs file: -;; -;; (require 'w3m-session) -;; -;; After restarting Emacs (or evaluating the form above), each time -;; you start emacs-w3m with 'w3m' you'll get a prompt asking whether -;; your last browsing session should be loaded. Likewise, when -;; quitting the browser, you'll have the possibility of saving your -;; current session (overwriting the previous one). -;; -;; In addition, two new interactive functions are defined: -;; -;; w3m-session-load -- load the last stored session -;; w3m-session-save -- save the current session -;; -;; These functions can be invoked at any time while running emacs-w3m. -;; Optionally, you can bind them to key shortcuts with the proper -;; variations of the following elisp magic in your .emacs: -;; (defun w3m-add-keys () -;; (define-key w3m-mode-map "S" 'w3m-session-save) -;; (define-key w3m-mode-map "L" 'w3m-session-load)) -;; (add-hook 'w3m-mode-hook 'w3m-add-keys) -;; -;; CUSTOMIZATION: -;; -;; A new customization group, w3m-session, is available. There you can -;; customize the following variables: -;; -;; w3m-session-load-always -- if t, `w3m-session-load' will *not* ask -;; for confirmation (default nil) -;; w3m-session-save-always -- if t, `w3m-session-load' will *not* ask -;; for confirmation (default nil) -;; w3m-session-show-titles -- if t, the load prompt will list the -;; session URL titles (default t) -;; w3m-session-duplicate-tabs -- what to do when loading a session that -;; contains a URL already open -;; w3m-session-file -- the file where w3m session info -;; is stored (default "~/.w3m-session") -;; w3m-session-autosave-period -- the period, in seconds, for automatic -;; session backup file updating. -;; -;; -;; You can also customize them in your .emacs file, to wit: -;; -;; (setq w3m-session-file "~/.emacs.d/w3m-session") -;; (setq w3m-session-save-always nil) -;; (setq w3m-session-load-always nil) -;; (setq w3m-session-show-titles t) -;; (setq w3m-session-duplicate-tabs 'ask) ; 'never, 'always, 'ask -;; -;; HISTORY: -;; -;; Version 0.3.5 (Sun Jan 14, 2007): -;; -;; - automatic session backup every `w3m-session-autosave-period' -;; seconds. -;; -;; Version 0.3.4 (Wed Jul 19, 2006): -;; -;; - save session file on quitting Emacs (without using -;; desktop.el) -;; -;; Version 0.3.3 (Thu Jun 8, 2006): -;; -;; - save session file with pretty print. -;; - handle correctly multiple emacs-w3m (re)starts during a -;; single emacs session. -;; - save URLs in hexified form to allow & in them. -;; - code cleanup. -;; -;; Version 0.3.2 (Mon Sep 29, 2003): -;; -;; - bug fix: when searching or going to home/bookmarks/etc, -;; keep the current tab's focus. -;; -;; Version 0.3.1 (Tue Aug 26, 2003): -;; -;; - type of `w3m-session-file' set to 'file' in customisation -;; buffer. -;; - bug fix: syntax error due to a typo in `w3m-session-file' -;; -;; Version 0.3 (Mon Aug 25, 2003): -;; -;; - the load session tab lists the titles of the session's pages -;; (customizable via 'w3m-session-show-titles'). -;; - the duplicated tab prompt displays also the URL's title. -;; - bug fix: active tab in session now is correctly saved. -;; -;; Version 0.2 (Fri Aug 22, 2003): -;; -;; - the session info now includes the active tab, which gets -;; displayed when the session is reloaded. -;; - when reloading a session in a running emacs-w3m, if the -;; session contains a URL that is already being displayed by the -;; browser, the tab can be reused or duplicated (customizable -;; via `w3m-session-duplicate-tabs'). -;; -;; Version 0.1 (Wed Aug 20, 2003) -- Initial release. -;; - - -;;; Code: - -;;; Dependencies: - -(require 'w3m) -(require 'advice) -(require 'url-util) - -;;; Custom variables: - -(defgroup w3m-session nil - "w3m - session saving in w3m." - :group 'w3m - :prefix "w3m-session-") - -(defcustom w3m-session-save-always nil - "If on, always save w3m session without asking." - :group 'w3m-session - :type 'boolean) - -(defcustom w3m-session-load-always nil - "If on, always load w3m session without asking." - :group 'w3m-session - :type 'boolean) - -(defcustom w3m-session-show-titles t - "If on, show URL titles in the load prompt." - :group 'w3m-session - :type 'boolean) - -(defcustom w3m-session-duplicate-tabs 'never - "How to treat session URL already being visited. - -When loading a session with `w3m-session-load', if one of the URLs in -the session is already displayed in a w3m tab, w3m-session can: -- `never' create a new tab (just reload it), or -- `always' duplicate the URL in a new tab, or -- `ask' the user what to do." - :group 'w3m-session - :type '(choice (const :value never) - (const :value always) - (const :value ask))) - -(defcustom w3m-session-file "~/.w3m-session" - "File to save the w3m session data." - :group 'w3m-session - :type 'file) - -(defvar w3m-session-autosave-period 180 - "A backup of the current session is saved with this period (in secs).") - -;;; Interactive functions: - -(defun w3m-session-save () - "Save the current w3m session." - (interactive) - (when (and (w3m-alive-p) - (or w3m-session-save-always - (y-or-n-p "Save current w3m session? "))) - (w3m-session-current-to-file) - (w3m-session--restart--autosave))) - -(defun w3m-session-load () - "Load last stored session into w3m." - (interactive) - (let ((s (w3m-session-load-aux))) - (when s - (w3m-session--restart--autosave) - (let* ((urls (w3m-session-url s)) - (offset (w3m-session-offset s)) - (buffers (unless (equal w3m-session-duplicate-tabs 'always) - (w3m-session-find-duplicated urls)))) - (w3m-goto-url-new-session urls t) - (when buffers (w3m-session-close-buffers buffers)) - (unless (zerop offset) (w3m-next-buffer offset)))))) - -(defun w3m-session-set-autosave-period (secs) - "Set new value for the period between session backup autosaves." - (interactive "p") - (let ((secs (or secs (read-number "New period (secs): " 0)))) - (when (> secs 0) - (setq w3m-session-autosave-period secs) - (w3m-session--restart--autosave)))) - -;;; Internals: - -;;;; advice w3m to use session management - -(defadvice w3m (before jao-load-session activate) - "Optionally load last w3m session on startup." - (interactive - (let ((s (w3m-session-load-aux))) - (list (or (and s (w3m-session-url s)) w3m-home-page) t t)))) - -(defadvice w3m (after jao-select-tab activate) - "Goto the saved focused tab" - (interactive) - (let ((offset (w3m-session-offset))) - (unless (zerop offset) - (w3m-next-buffer offset)) - (ad-deactivate 'w3m))) - -(defadvice w3m-quit (before jao-save-session activate) - "Save session before quitting." - (interactive) - (w3m-session-save) - ;; this is a little hack: when quitting a w3m session with a tab - ;; selected other than the first, the frame is not automatically - ;; closed as should be when w3m-pop-up-frames is t: - (switch-to-buffer (car (w3m-list-buffers))) - (ad-activate 'w3m)) - -;;;; save session on exit -(add-to-list 'kill-emacs-query-functions - '(lambda () (w3m-session-save) t)) - - -;;;; auxiliar functions - -(defvar jao-w3m-current-session '(w3m-session 0 nil)) - -(defun w3m-session-url (&optional s) - (let ((s (or s jao-w3m-current-session))) - (concat "group:" - (mapconcat 'car (nth 2 s) "&")))) - -(defun w3m-session-offset (&optional s) - (let ((s (or s jao-w3m-current-session))) - (nth 1 s))) - -(defun w3m-session-titles (&optional s) - (let ((s (or s jao-w3m-current-session))) - (mapcar 'cdr (nth 2 s)))) - -(defun w3m-session-current (&optional s) - (save-current-buffer - (setq jao-w3m-current-session - (or s - `(w3m-session - ,(w3m-session-active-tab) - ,(mapcar - (lambda (b) (set-buffer b) - (cons (url-hexify-string w3m-current-url) - (w3m-buffer-title b))) (w3m-list-buffers))))))) - -(defun w3m-session-current-url () - (when (w3m-alive-p) - (save-current-buffer - (concat "group:" - (mapconcat (lambda (b) (set-buffer b) w3m-current-url) - (w3m-list-buffers) "&"))))) - -(defun w3m-session-active-tab (&optional n bs alive) - (let ((n (or n 0)) - (bs (or bs (w3m-list-buffers))) - (alive (or alive (w3m-alive-p)))) - (if (equal alive (car bs)) n - (w3m-session-active-tab (incf n) (cdr bs) alive)))) - -(defun w3m-session-find-duplicated (urls) - (when (w3m-alive-p) - (save-current-buffer - (let* ((duplicate-p - (lambda (b) - (y-or-n-p - (format "'%s' (%s) is already open. Duplicate tab? " - (w3m-buffer-title b) w3m-current-url)))) - (test-b - (lambda (b) - (set-buffer b) - (if (and - (string-match (regexp-quote w3m-current-url) urls) - (or (equal w3m-session-duplicate-tabs 'never) - (not (funcall duplicate-p b)))) - b 'not))) - (buffers (mapcar test-b (w3m-list-buffers)))) - (delete 'not buffers))))) - -(defun w3m-session-close-buffers (buffers) - (save-current-buffer - (mapc 'kill-buffer buffers))) - -(defun w3m-session-load-aux () - (let ((new-session (w3m-session-from-file - (expand-file-name w3m-session-file)))) - (if (and new-session - (or w3m-session-load-always - (y-or-n-p - (if w3m-session-show-titles - (format "Load last w3m session %S? " - (w3m-session-titles new-session)) - "Load last w3m session? ")))) - (w3m-session-current new-session) - nil))) - -(defun w3m-session-from-file (fname) - (let ((fname (w3m-session--check--backup fname))) - (if (file-readable-p fname) - (with-temp-buffer - (insert-file-contents fname) - (goto-char (point-min)) - (let ((sexp (read (current-buffer)))) - (and (equal 'w3m-session (car sexp)) sexp))) - nil))) - -(defsubst w3m-session-current-to-file () - (w3m-session--to--file w3m-session-file)) - -(defun w3m-session--to--file (filename &optional is-auto) - (require 'pp) - (let ((msg (if is-auto (current-message)))) - (with-temp-buffer - (insert ";;;; File generated by w3m-session. DO NOT EDIT!\n") - (pp (w3m-session-current) (current-buffer)) - (insert "\n" ";;;; End of " - (file-name-nondirectory w3m-session-file) "\n") - (write-region (point-min) (point-max) (expand-file-name filename))) - (if is-auto (message msg)))) - -(defvar w3m-session--timer nil) - -(defun w3m-session--backup-name (fname) - (concat (expand-file-name fname) ".bak")) - -(defun w3m-session--check--backup (fname) - (let ((bfname (w3m-session--backup-name fname))) - (if (and (file-newer-than-file-p bfname fname) - (y-or-n-p "A newer autosaved session exists. Use it? ")) - bfname - fname))) - -(defun w3m-session--restart--autosave () - (when (> w3m-session-autosave-period 0) - (if w3m-session--timer (cancel-timer w3m-session--timer)) - (setq w3m-session--timer - (run-at-time w3m-session-autosave-period - w3m-session-autosave-period - 'w3m-session--to--file - (w3m-session--backup-name w3m-session-file) - t)))) - -(provide 'w3m-session) - -;;; w3m-session.el ends here rmfile ./site-lisp/w3m-session.el }