scel/el/sclang-interp.el

714 lines
23 KiB
EmacsLisp
Raw Normal View History

;; copyright 2003-2005 stefan kersten <steve@k-hornz.de>
;;
;; 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
(eval-when-compile
(require 'cl))
(eval-and-compile
(require 'sclang-util))
;; =====================================================================
;; post buffer access
;; =====================================================================
;; FIXME: everything will fail when renaming the post buffer!
(defconst sclang-post-buffer (sclang-make-buffer-name "PostBuffer")
"Name of the SuperCollider process output buffer.")
(defconst sclang-bullet-latin-1 (string-to-char (decode-coding-string "\xa5" 'utf-8))
"Character for highlighting errors (latin-1).")
(defconst sclang-bullet-utf-8 (string-to-char (decode-coding-string "\xe2\x80\xa2" 'utf-8))
"Character for highlighting errors (utf-8).")
(defconst sclang-parse-error-regexp
"^\\(WARNING\\|ERROR\\): .*\n[\t ]*in file '\\([^']\+\\)'\n[\t ]*line \\([0-9]\+\\) char \\([0-9]\+\\)"
"Regular expression matching parse errors during library compilation.")
(defcustom sclang-max-post-buffer-size 0
"*Maximum number of characters to insert in post buffer.
Zero means no limit."
:group 'sclang-interface
:version "21.3"
:type 'integer)
(defcustom sclang-auto-scroll-post-buffer nil
"*Automatically scroll post buffer on output regardless of point position.
Default behavior is to only scroll when point is not at end of buffer."
:group 'sclang-interface
:version "21.3"
:type 'boolean)
(defun sclang-get-post-buffer ()
(get-buffer-create sclang-post-buffer))
(defmacro with-sclang-post-buffer (&rest body)
`(with-current-buffer (sclang-get-post-buffer)
,@body))
;; (defun sclang-post-string (string)
;; (with-sclang-post-buffer
;; (let ((eobp (mapcar (lambda (w)
;; (cons w (= (window-point w) (point-max))))
;; (get-buffer-window-list (current-buffer) nil t))))
;; (save-excursion
;; ;; insert STRING into process buffer
;; (goto-char (point-max))
;; (insert string))
;; (dolist (assoc eobp)
;; (when (cdr assoc)
;; (save-selected-window
;; (let ((window (car assoc)))
;; (select-window window)
;; (set-window-point window (point-max))
;; (recenter -1))))))))
;; (defun sclang-post-string (string &optional proc)
;; (let* ((buffer (process-buffer proc))
;; (window (display-buffer buffer)))
;; (with-current-buffer buffer
;; (let ((moving (= (point) (process-mark proc))))
;; (save-excursion
;; ;; Insert the text, advancing the process marker.
;; (goto-char (process-mark proc))
;; (insert string)
;; (set-marker (process-mark proc) (point)))
;; (when moving
;; (goto-char (process-mark proc))
;; (set-window-point window (process-mark proc)))))))
(defun sclang-show-post-buffer (&optional eob-p)
"Show SuperCollider process buffer.
If EOB-P is non-nil, positions cursor at end of buffer."
(interactive "P")
(with-sclang-post-buffer
(let ((window (display-buffer (current-buffer) :frame t)))
(when eob-p
(goto-char (point-max))
(save-selected-window
(set-window-point window (point-max)))))))
(defun sclang-clear-post-buffer ()
"Clear the output buffer."
(interactive)
(with-sclang-post-buffer (erase-buffer)))
(defun sclang-init-post-buffer ()
"Initialize post buffer."
(get-buffer-create sclang-post-buffer)
(with-sclang-post-buffer
;; setup sclang mode
(sclang-mode)
(set (make-local-variable 'font-lock-fontify-region-function)
(lambda (&rest args)))
;; setup compilation mode
(compilation-minor-mode)
(set (make-variable-buffer-local 'compilation-error-screen-columns) nil)
(set (make-variable-buffer-local 'compilation-error-regexp-alist)
(cons (list sclang-parse-error-regexp 2 3 4) compilation-error-regexp-alist))
(set (make-variable-buffer-local 'compilation-parse-errors-function)
(lambda (limit-search find-at-least)
(compilation-parse-errors limit-search find-at-least)))
(set (make-variable-buffer-local 'compilation-parse-errors-filename-function)
(lambda (file-name)
file-name)))
(sclang-clear-post-buffer)
(sclang-show-post-buffer))
;; =====================================================================
;; interpreter interface
;; =====================================================================
(defconst sclang-process "SCLang"
"Name of the SuperCollider interpreter subprocess.")
(defcustom sclang-program "sclang"
"*Name of the SuperCollider interpreter program."
:group 'sclang-programs
:version "21.3"
:type 'string)
(defcustom sclang-runtime-directory ""
"*Path to the SuperCollider runtime directory."
:group 'sclang-options
:version "21.3"
:type 'directory
:options '(:must-match))
(defcustom sclang-library-configuration-file ""
"*Path of the library configuration file."
:group 'sclang-options
:version "21.3"
:type 'file
:options '(:must-match))
(defcustom sclang-heap-size ""
"*Initial heap size."
:group 'sclang-options
:version "21.3"
:type 'string)
(defcustom sclang-heap-growth ""
"*Heap growth."
:group 'sclang-options
:version "21.3"
:type 'string)
(defcustom sclang-udp-port -1
"*UDP listening port."
:group 'sclang-options
:version "21.3"
:type 'integer)
(defcustom sclang-main-run nil
"*Call Main.run on startup."
:group 'sclang-options
:version "21.3"
:type 'boolean)
(defcustom sclang-main-stop nil
"*Call Main.stop on shutdown."
:group 'sclang-options
:version "21.3"
:type 'boolean)
;; =====================================================================
;; helper functions
;; =====================================================================
(defun sclang-get-process ()
(get-process sclang-process))
;; =====================================================================
;; library startup/shutdown
;; =====================================================================
(defvar sclang-library-initialized-p nil)
(defcustom sclang-library-startup-hook nil
"*Hook run after initialization of the SCLang process."
:group 'sclang-interface
:type 'hook)
(defcustom sclang-library-shutdown-hook nil
"*Hook run before deletion of the SCLang process."
:group 'sclang-interface
:type 'hook)
;; library initialization works like this:
;;
;; * emacs starts sclang with SCLANG_COMMAND_FIFO set in the environment
;; * sclang opens fifo for communication with emacs during class tree
;; initialization
;; * sclang sends '_init' command
;; * '_init' command handler calls sclang-on-library-startup to complete
;; initialization
(defun sclang-library-initialized-p ()
(and (sclang-get-process)
sclang-library-initialized-p))
(defun sclang-on-library-startup ()
(sclang-message "Initializing library...")
(setq sclang-library-initialized-p t)
(run-hooks 'sclang-library-startup-hook)
(sclang-message "Initializing library...done"))
(defun sclang-on-library-shutdown ()
(run-hooks 'sclang-library-shutdown-hook)
(setq sclang-library-initialized-p nil))
;; =====================================================================
;; process hooks
;; =====================================================================
(defun sclang-process-sentinel (proc msg)
(with-sclang-post-buffer
(goto-char (point-max))
(insert
(if (and (bolp) (eolp)) "\n" "\n\n")
(format "*** %s %s ***" proc (substring msg 0 -1))
"\n\n"))
(when (memq (process-status proc) '(exit signal))
(sclang-on-library-shutdown)))
(defun sclang-process-filter (process string)
(let ((buffer (process-buffer process)))
(with-current-buffer buffer
(when (and (> sclang-max-post-buffer-size 0)
(> (buffer-size) sclang-max-post-buffer-size))
(erase-buffer))
(let ((move-point (or sclang-auto-scroll-post-buffer
(= (point) (process-mark process)))))
(save-excursion
;; replace mac-roman bullet with unicode character
(subst-char-in-string sclang-bullet-latin-1 sclang-bullet-utf-8 string t)
;; insert the text, advancing the process marker.
(goto-char (process-mark process))
(insert string)
(set-marker (process-mark process) (point)))
(when move-point
(goto-char (process-mark process))
(walk-windows
(lambda (window)
(when (eq buffer (window-buffer window))
(set-window-point window (process-mark process))))
nil t))))))
;; =====================================================================
;; process startup/shutdown
;; =====================================================================
(defun sclang-memory-option-p (string)
(let ((case-fold-search nil))
(string-match "^[1-9][0-9]*[km]?$" string)))
(defun sclang-port-option-p (number)
(and (>= number 0) (<= number #XFFFF)))
(defun sclang-make-options ()
(let ((default-directory "")
(res ()))
(flet ((append-option
(option &optional value)
(setq res (append res (list option) (and value (list value))))))
(if (file-directory-p sclang-runtime-directory)
(append-option "-d" (expand-file-name sclang-runtime-directory)))
(if (file-exists-p sclang-library-configuration-file)
(append-option "-l" (expand-file-name sclang-library-configuration-file)))
(if (sclang-memory-option-p sclang-heap-size)
(append-option "-m" sclang-heap-size))
(if (sclang-memory-option-p sclang-heap-growth)
(append-option "-g" sclang-heap-growth))
(if (sclang-port-option-p sclang-udp-port)
(append-option "-u" (number-to-string sclang-udp-port)))
(if sclang-main-run
(append-option "-r"))
(if sclang-main-stop
(append-option "-s"))
res)))
(defun sclang-start ()
"Start SuperCollider process."
(interactive)
(sclang-stop)
(sit-for 1)
(sclang-init-post-buffer)
(sclang-start-command-process)
(let ((process-connection-type nil))
(let ((proc (apply 'start-process
sclang-process sclang-post-buffer
sclang-program (sclang-make-options))))
(set-process-sentinel proc 'sclang-process-sentinel)
(set-process-filter proc 'sclang-process-filter)
(set-process-coding-system proc 'mule-utf-8 'mule-utf-8)
(process-kill-without-query proc)
proc)))
(defun sclang-kill ()
"Kill SuperCollider process."
(interactive)
(when (sclang-get-process)
(kill-process sclang-process)
(delete-process sclang-process)))
(defun sclang-stop ()
"Stop SuperCollider process."
(interactive)
(when (sclang-get-process)
(process-send-eof sclang-process)
(let ((tries 4)
(i 0))
(while (and (sclang-get-process)
(< i tries))
(incf i)
(sit-for 0.5))))
(sclang-kill)
(sclang-release-command-fifo))
;; =====================================================================
;; command process
;; =====================================================================
(defcustom sclang-mkfifo-program "mkfifo"
"*Name of the \"mkfifo\" program.
Change this if \"mkfifo\" has a non-standard name or location."
:group 'sclang-programs
:type 'string)
(defcustom sclang-cat-program "cat"
"*Name of the \"cat\" program.
Change this if \"cat\" has a non-standard name or location."
:group 'sclang-programs
:type 'string)
(defconst sclang-command-process "SCLang Command"
"Subprocess for receiving command results from sclang.")
(defvar sclang-command-fifo nil
"FIFO for communicating with the subprocess.")
(defun sclang-delete-command-fifo ()
(and sclang-command-fifo
(file-exists-p sclang-command-fifo)
(delete-file sclang-command-fifo)))
(defun sclang-release-command-fifo ()
(sclang-delete-command-fifo)
(setq sclang-command-fifo nil))
(defun sclang-create-command-fifo ()
(setq sclang-command-fifo (make-temp-name
(expand-file-name
"sclang-command-fifo." temporary-file-directory)))
(sclang-delete-command-fifo)
(let ((res (call-process sclang-mkfifo-program
nil t t
sclang-command-fifo)))
(unless (eq 0 res)
(message "SCLang: Couldn't create command fifo")
(setq sclang-command-fifo nil))))
(defun sclang-command-process-sentinel (proc msg)
(and (memq (process-status proc) '(exit signal))
(sclang-release-command-fifo)))
(defun sclang-start-command-process ()
(sclang-create-command-fifo)
(when sclang-command-fifo
;; sclang gets the fifo path via the environment
(setenv "SCLANG_COMMAND_FIFO" sclang-command-fifo)
(let ((process-connection-type nil))
(let ((proc (start-process
sclang-command-process nil
sclang-cat-program sclang-command-fifo)))
(set-process-sentinel proc 'sclang-command-process-sentinel)
(set-process-filter proc 'sclang-command-process-filter)
;; this is important. use a unibyte stream without eol
;; conversion for communication.
(set-process-coding-system proc 'no-conversion 'no-conversion)
(process-kill-without-query proc)))
(unless (get-process sclang-command-process)
(message "SCLang: Couldn't start command process"))))
(defvar sclang-command-process-previous nil
"Unprocessed command process output.")
(defun sclang-command-process-filter (proc string)
(when sclang-command-process-previous
(setq string (concat sclang-command-process-previous string)))
(let (end)
(while (and (> (length string) 3)
(>= (length string)
(setq end (+ 4 (sclang-string-to-int32 string)))))
(sclang-handle-command-result (car (read-from-string string 4 end)))
(setq string (substring string end))))
(setq sclang-command-process-previous string))
;; =====================================================================
;; command interface
;; =====================================================================
;; symbol property: sclang-command-handler
(defun sclang-set-command-handler (symbol function)
(put symbol 'sclang-command-handler function))
(defun sclang-perform-command (symbol &rest args)
(sclang-eval-string (sclang-format
"Emacs.lispPerformCommand(%o, %o, true)"
symbol args)))
(defun sclang-perform-command-no-result (symbol &rest args)
(sclang-eval-string (sclang-format
"Emacs.lispPerformCommand(%o, %o, false)"
symbol args)))
(defun sclang-default-command-handler (fun arg)
"Default command handler.
Displays short message on error."
(condition-case nil
(funcall fun arg)
(error (sclang-message "Error in command handler") nil)))
(defun sclang-debug-command-handler (fun arg)
"Debugging command handler.
Enters debugger on error."
(let ((debug-on-error t)
(debug-on-signal t))
(funcall fun arg)))
(defvar sclang-command-handler 'sclang-default-command-handler
"Function called when handling command result.")
(defun sclang-toggle-debug-command-handler (&optional arg)
"Toggle debugging of command handler.
With arg, activate debugging iff arg is positive."
(interactive "P")
(setq sclang-command-handler
(if (or (and arg (> arg 0))
(eq sclang-command-handler 'sclang-debug-command-handler))
'sclang-default-command-handler
'sclang-default-command-handler))
(sclang-message "Command handler debugging %s."
(if (eq sclang-command-handler 'sclang-debug-command-handler)
"enabled"
"disabled")))
(defun sclang-handle-command-result (list)
(condition-case nil
(let ((fun (get (nth 0 list) 'sclang-command-handler))
(arg (nth 1 list))
(id (nth 2 list)))
(when (functionp fun)
(let ((res (funcall sclang-command-handler fun arg)))
(when id
(sclang-eval-string
(sclang-format "Emacs.lispHandleCommandResult(%o, %o)" id res))))))
(error nil)))
;; =====================================================================
;; code evaluation
;; =====================================================================
(defconst sclang-token-interpret-cmd-line (char-to-string #X1b))
(defconst sclang-token-interpret-print-cmd-line (char-to-string #X0c))
(defcustom sclang-eval-line-forward t
"*If non-nil `sclang-eval-line' advances to the next line."
:group 'sclang-interface
:type 'boolean)
(defun sclang-send-string (token string &optional force)
(let ((proc (sclang-get-process)))
(when (and proc (or (sclang-library-initialized-p) force))
(process-send-string proc (concat string token))
string)))
(defun sclang-eval-string (string &optional print-p)
"Send STRING to the sclang process for evaluation and print the result
if PRINT-P is non-nil. Return STRING if successful, otherwise nil."
(sclang-send-string
(if print-p sclang-token-interpret-print-cmd-line sclang-token-interpret-cmd-line)
string))
(defun sclang-eval-expression (string &optional silent-p)
"Execute STRING as SuperCollider code."
(interactive "sEval: \nP")
(sclang-eval-string string (not silent-p)))
(defun sclang-eval-line (&optional silent-p)
"Execute the current line as SuperCollider code."
(interactive "P")
(let ((string (sclang-line-at-point)))
(when string
(sclang-eval-string string (not silent-p)))
(and sclang-eval-line-forward
(/= (line-end-position) (point-max))
(next-line 1))
string))
(defun sclang-eval-region (&optional silent-p)
"Execute the region as SuperCollider code."
(interactive "P")
(sclang-eval-string
(buffer-substring-no-properties (region-beginning) (region-end))
(not silent-p)))
(defun sclang-eval-region-or-line (&optional silent-p)
(interactive "P")
(if (and transient-mark-mode mark-active)
(sclang-eval-region silent-p)
(sclang-eval-line silent-p)))
(defun sclang-eval-defun (&optional silent-p)
(interactive "P")
(let ((string (sclang-defun-at-point)))
(when (and string (string-match "^(" string))
(sclang-eval-string string (not silent-p))
string)))
(defvar sclang-eval-results nil
"Save results of sync SCLang evaluation.")
(sclang-set-command-handler
'evalSCLang
(lambda (arg) (push arg sclang-eval-results)))
(defun sclang-eval-sync (string)
"Eval STRING in sclang and return result as a lisp value."
(let ((proc (get-process sclang-command-process)))
(if (and (processp proc) (eq (process-status proc) 'run))
(let ((time (current-time)) (tick 10000) elt)
(sclang-perform-command 'evalSCLang string time)
(while (and (> (decf tick) 0)
(not (setq elt (find time sclang-eval-results
:key #'car :test #'equal))))
(accept-process-output proc 0 100))
(if elt
(prog1 (if (eq (nth 1 elt) 'ok)
(nth 2 elt)
(setq sclang-eval-results (delq elt sclang-eval-results))
(signal 'sclang-error (nth 2 elt)))
(setq sclang-eval-results (delq elt sclang-eval-results)))
(error "SCLang sync eval timeout")))
(error "SCLang Command process not running"))))
;; =====================================================================
;; searching
;; =====================================================================
;; (defun sclang-help-file-paths ()
;; "Return a list of help file paths."
;; (defun sclang-grep-help-files ()
;; (interactive)
;; (let ((sclang-grep-prompt "Search help files: ")
;; (sclang-grep-files (mapcar 'cdr sclang-help-topic-alist)))
;; (call-interactively 'sclang-grep-files)))
;; (defvar sclang-grep-history nil)
;; (defcustom sclang-grep-case-fold-search t
;; "*Non-nil if sclang-grep-files should ignore case."
;; :group 'sclang-interface
;; :version "21.4"
;; :type 'boolean)
;; (defvar sclang-grep-files nil)
;; (defvar sclang-grep-prompt "Grep: ")
;; (defun sclang-grep-files (regexp)
;; (interactive
;; (let ((grep-default (or (when current-prefix-arg (sclang-symbol-at-point))
;; (car sclang-grep-history))))
;; (list (read-from-minibuffer sclang-grep-prompt
;; grep-default
;; nil nil 'sclang-grep-history))))
;; (grep-compute-defaults)
;; (grep (concat grep-program
;; " -n"
;; (and sclang-grep-case-fold-search " -i")
;; " -e" regexp
;; " " (mapconcat 'shell-quote-argument sclang-grep-files " "))))
;; =====================================================================
;; workspace
;; =====================================================================
(defcustom sclang-show-workspace-on-startup t
"*If non-nil show the workspace buffer on library startup."
:group 'sclang-interface
:type 'boolean)
(defconst sclang-workspace-buffer (sclang-make-buffer-name "Workspace"))
(defun sclang-fill-workspace-mode-map (map)
(define-key map "\C-c}" 'bury-buffer))
(defun sclang-switch-to-workspace ()
(interactive)
(let ((buffer (get-buffer sclang-workspace-buffer)))
(unless buffer
(setq buffer (get-buffer-create sclang-workspace-buffer))
(with-current-buffer buffer
(sclang-mode)
(let ((map (make-sparse-keymap)))
(set-keymap-parent map sclang-mode-map)
(sclang-fill-workspace-mode-map map)
(use-local-map map))
(let ((line (concat "// " (make-string 69 ?=) "\n")))
(insert line)
(insert "// SuperCollider Workspace\n")
(insert line)
;; (insert "// using HTML Help: C-c C-h as usual, then switch to w3m buffer\n")
;; (insert "// and do M-x sclang-minor-mode in order te enable sclang code execution\n")
;; (insert line)
(insert "\n"))
(set-buffer-modified-p nil)
;; cwd to sclang-runtime-directory
(if (and sclang-runtime-directory
(file-directory-p sclang-runtime-directory))
(setq default-directory sclang-runtime-directory))))
(switch-to-buffer buffer)))
(add-hook 'sclang-library-startup-hook
(lambda () (and sclang-show-workspace-on-startup
(sclang-switch-to-workspace))))
;; =====================================================================
;; language control
;; =====================================================================
(defun sclang-main-run ()
(interactive)
(sclang-eval-string "thisProcess.run"))
(defun sclang-main-stop ()
(interactive)
(sclang-eval-string "thisProcess.stop"))
;; =====================================================================
;; default command handlers
;; =====================================================================
(sclang-set-command-handler '_init (lambda (arg) (sclang-on-library-startup)))
(sclang-set-command-handler
'_eval
(lambda (expr)
(when (stringp expr)
(eval (read expr)))))
;; =====================================================================
;; module setup
;; =====================================================================
;; shutdown process cleanly
(add-hook 'kill-emacs-hook (lambda () (sclang-stop)))
;; add command line switches
(add-to-list 'command-switch-alist
(cons "sclang"
(lambda (switch)
(sclang-start))))
(add-to-list 'command-switch-alist
(cons "sclang-debug"
(lambda (switch)
(sclang-toggle-debug-command-handler 1))))
(add-to-list 'command-switch-alist
(cons "scmail"
(lambda (switch)
(sclang-start)
(when command-line-args-left
(let ((file (pop command-line-args-left)))
(with-current-buffer (get-buffer-create sclang-workspace-buffer)
(and (file-exists-p file) (insert-file-contents file))
(set-buffer-modified-p nil)
(sclang-mode)
(switch-to-buffer (current-buffer))))))))
(provide 'sclang-interp)
;; EOF