move scel to editors
git-svn-id: https://supercollider.svn.sourceforge.net/svnroot/supercollider/trunk@8370 a380766d-ff14-0410-b294-a243070f3f08
This commit is contained in:
Marije Baalman
commit
89fba7d169
25 changed files with 6444 additions and 0 deletions
121
README
Normal file
121
README
Normal file
|
|
@ -0,0 +1,121 @@
|
|||
-*- text -*-
|
||||
------------------------------------------------------------------------
|
||||
SCEL -- SuperCollider/Emacs interface
|
||||
------------------------------------------------------------------------
|
||||
$Id"
|
||||
------------------------------------------------------------------------
|
||||
|
||||
installation (requirements)
|
||||
---------------------------
|
||||
|
||||
For the HTML help system, you will need emacs-w3m support.
|
||||
|
||||
installation (default)
|
||||
-----------------------
|
||||
|
||||
by default emacs-lisp files are installed in
|
||||
|
||||
$prefix/share/emacs/site-lisp
|
||||
|
||||
SuperCollider files are put in
|
||||
|
||||
$prefix/share/SuperCollider/Extensions/scel
|
||||
|
||||
the only thing you need to do is loading the sclang interface in your
|
||||
~/.emacs:
|
||||
|
||||
(require 'sclang)
|
||||
|
||||
for the HTML help system to fully function also add
|
||||
(require 'w3m)
|
||||
|
||||
installation (detailed)
|
||||
------------------------
|
||||
|
||||
put all *.el files in emacs' load-path. e.g. if you put them in
|
||||
~/emacs/, add the following lines to ~/.emacs (or whatever your init
|
||||
file is called):
|
||||
|
||||
(add-to-list 'load-path "~/emacs")
|
||||
|
||||
and then load the library:
|
||||
|
||||
(require 'sclang)
|
||||
|
||||
for the HTML help system to fully function also add
|
||||
(require 'w3m)
|
||||
|
||||
now put all *.sc files in sclang's library path, e.g. if you put them
|
||||
in a non-standard location, such as ~/SuperCollider/Emacs/, add the
|
||||
following to ~/.sclang.cfg:
|
||||
|
||||
+~/SuperCollider/Emacs
|
||||
|
||||
(note normally this is not needed as they are put into sclang's library
|
||||
path during installation with scons).
|
||||
|
||||
|
||||
usage
|
||||
------
|
||||
|
||||
in order to automatically start sclang when invoking emacs, use the
|
||||
following command line:
|
||||
|
||||
$ emacs -sclang
|
||||
|
||||
you're now ready to edit, inspect and execute sclang code!
|
||||
|
||||
getting help
|
||||
-------------
|
||||
|
||||
inside an sclang-mode buffer (e.g. by editing a .sc file), execute
|
||||
|
||||
C-h m
|
||||
|
||||
a window with key bindings in sclang-mode will pop up.
|
||||
|
||||
C-x C-h lets you search for a help file
|
||||
|
||||
C-M-h opens or switches to the Help browser (if no Help file has been opened, the default Help file will be opened)
|
||||
|
||||
E copies the buffer, puts it in text mode and sclang-minor-mode, to enable you to edit the code parts to try out variations of the provided code in the help file. With C-M-h you can then return to the Help browser and browse further from the Help file.
|
||||
|
||||
C-c C-e allows you to edit the source of the HTML file, for example if you want to improve it and commit it to the repository.
|
||||
|
||||
To enable moving around in the help file with arrow keys add the following
|
||||
in your ~/.emacs:
|
||||
|
||||
(eval-after-load "w3m"
|
||||
'(progn
|
||||
(define-key w3m-mode-map [left] 'backward-char)
|
||||
(define-key w3m-mode-map [right] 'forward-char)
|
||||
(define-key w3m-mode-map [up] 'previous-line)
|
||||
(define-key w3m-mode-map [down] 'next-line)))
|
||||
|
||||
This ensures that the arrow keys are just for moving through the document,
|
||||
and not from hyperlink to hyperlink, which is the default in w3m-mode.
|
||||
|
||||
|
||||
customization
|
||||
--------------
|
||||
|
||||
to fine-tune the installation from within emacs' graphical
|
||||
customization interface, type
|
||||
|
||||
M-x sclang-customize
|
||||
|
||||
in particular, you will have to customize `sclang-runtime-directory'.
|
||||
|
||||
server control
|
||||
---------------
|
||||
|
||||
in the post buffer window, right-click on the server name; by default
|
||||
the two servers 'internal' and 'localhost' are available. you will get
|
||||
a menu with common server control operations.
|
||||
|
||||
to select another server, step through the server list by
|
||||
left-clicking on the server name.
|
||||
|
||||
servers instantiated from the language will automatically be available
|
||||
in the mode line.
|
||||
|
||||
183
el/sclang-browser.el
Normal file
183
el/sclang-browser.el
Normal file
|
|
@ -0,0 +1,183 @@
|
|||
;; copyright 2003 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
|
||||
|
||||
(require 'sclang-util)
|
||||
(require 'view nil t)
|
||||
|
||||
;; TODO: better factoring
|
||||
;; derive from view mode, make mode-map pluggable
|
||||
;; define derived mode for completion, definition, help
|
||||
|
||||
(defun sclang-browser-fill-keymap (map)
|
||||
(define-key map "\r" 'sclang-browser-follow-link)
|
||||
(define-key map [mouse-2] 'sclang-browser-mouse-follow-link)
|
||||
(define-key map "\t" 'sclang-browser-next-link)
|
||||
(define-key map [backtab] 'sclang-browser-previous-link)
|
||||
(define-key map [(shift tab)] 'sclang-browser-previous-link)
|
||||
(define-key map [?q] 'sclang-browser-quit)
|
||||
map)
|
||||
|
||||
(defvar sclang-browser-mode-map (sclang-browser-fill-keymap (make-sparse-keymap)))
|
||||
(defvar sclang-browser-mode-hook nil)
|
||||
(defvar sclang-browser-show-hook nil)
|
||||
(defvar sclang-browser-link-function nil
|
||||
"buffer local")
|
||||
(defvar sclang-browser-return-method nil
|
||||
"buffer local")
|
||||
|
||||
(defun sclang-browser-beginning-of-link ()
|
||||
(interactive)
|
||||
(when (get-text-property (point) 'sclang-browser-link)
|
||||
(while (and (not (bobp))
|
||||
(get-text-property (point) 'sclang-browser-link))
|
||||
(forward-char -1))
|
||||
(unless (bobp) (forward-char 1))
|
||||
(point)))
|
||||
|
||||
(defun sclang-browser-next-link (&optional n)
|
||||
(interactive)
|
||||
(let* ((n (or n 1))
|
||||
(prop 'sclang-browser-link)
|
||||
(fwd (>= n 0))
|
||||
(orig (point))
|
||||
(beg (if fwd (point-min) (point-max)))
|
||||
(end (if fwd (point-max) (point-min)))
|
||||
(inc (if fwd 1 -1))
|
||||
pos)
|
||||
(when (get-text-property (point) prop)
|
||||
(while (and (/= (point) beg)
|
||||
(get-text-property (point) prop))
|
||||
(forward-char inc))
|
||||
(if (= (point) beg) (goto-char end)))
|
||||
(while (not (eq pos orig))
|
||||
(cond ((get-text-property (point) prop)
|
||||
(sclang-browser-beginning-of-link)
|
||||
(setq pos orig))
|
||||
(t
|
||||
(if (= (point) end) (goto-char beg))
|
||||
(forward-char inc)
|
||||
(setq pos (point)))))))
|
||||
|
||||
(defun sclang-browser-previous-link ()
|
||||
(interactive)
|
||||
(sclang-browser-next-link -1))
|
||||
|
||||
(defun sclang-browser-follow-link (&optional pos)
|
||||
(interactive)
|
||||
(let* ((pos (or pos (point)))
|
||||
(data (get-text-property pos 'sclang-browser-link)))
|
||||
(when (consp data)
|
||||
(let ((fun (or (car data) sclang-browser-link-function))
|
||||
(arg (cdr data)))
|
||||
(when (functionp fun)
|
||||
(condition-case nil
|
||||
(funcall fun arg)
|
||||
(error (sclang-message "Error in link function") nil)))))))
|
||||
|
||||
(defun sclang-browser-mouse-follow-link (event)
|
||||
(interactive "e")
|
||||
(let* ((start (event-start event))
|
||||
(window (car start))
|
||||
(pos (cadr start)))
|
||||
(with-current-buffer (window-buffer window)
|
||||
(sclang-browser-follow-link pos))))
|
||||
|
||||
(defun sclang-browser-mode ()
|
||||
"Major mode for viewing hypertext and navigating references in it.
|
||||
Entry to this mode runs the normal hook `sclang-browser-mode-hook'.
|
||||
Commands:
|
||||
\\{sclang-browser-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map sclang-browser-mode-map)
|
||||
(set-keymap-parent sclang-browser-mode-map view-mode-map)
|
||||
(setq mode-name "Browser")
|
||||
(setq major-mode 'sclang-browser-mode)
|
||||
(set (make-local-variable 'sclang-browser-link-function) nil)
|
||||
(set (make-local-variable 'sclang-browser-return-method) nil)
|
||||
(set (make-local-variable 'font-lock-defaults) nil)
|
||||
(view-mode)
|
||||
(set (make-local-variable 'minor-mode-overriding-map-alist)
|
||||
(list (cons 'view-mode sclang-browser-mode-map)))
|
||||
(set (make-local-variable 'view-no-disable-on-exit) t)
|
||||
(run-hooks 'sclang-browser-mode-hook))
|
||||
|
||||
(defun sclang-browser-mode-setup ()
|
||||
(sclang-browser-mode)
|
||||
(setq buffer-read-only nil))
|
||||
|
||||
(defun sclang-browser-mode-finish ()
|
||||
(toggle-read-only 1)
|
||||
(setq view-return-to-alist
|
||||
(list (cons (selected-window) sclang-browser-return-method)))
|
||||
(run-hooks 'sclang-browser-show-hook))
|
||||
|
||||
(defun sclang-browser-quit ()
|
||||
(interactive)
|
||||
(when (eq major-mode 'sclang-browser-mode)
|
||||
(kill-buffer (current-buffer))))
|
||||
|
||||
(defun sclang-browser-make-link (link-text &optional link-data link-function)
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(propertize link-text
|
||||
'mouse-face 'highlight
|
||||
;;'help-echo "mouse-2: follow link"
|
||||
;;'keymap map
|
||||
'sclang-browser-link (cons link-function link-data)
|
||||
;;'sclang-browser-link-data link-data
|
||||
;;'sclang-browser-link-function link-function)))
|
||||
)))
|
||||
|
||||
(defun sclang-display-browser (buffer-name output-function)
|
||||
"header: what to insert in the buffer
|
||||
link-list: list of (link-text link-function link-data)
|
||||
link-function: function with args (link-text link-data)"
|
||||
(let ((temp-buffer-setup-hook '(sclang-browser-mode-setup))
|
||||
(temp-buffer-show-hook '(sclang-browser-mode-finish)))
|
||||
(with-output-to-temp-buffer buffer-name
|
||||
(with-current-buffer standard-output
|
||||
;; record return method
|
||||
(setq sclang-browser-return-method
|
||||
(cond ((special-display-p (buffer-name standard-output))
|
||||
;; If the help output buffer is a special display buffer,
|
||||
;; don't say anything about how to get rid of it.
|
||||
;; First of all, the user will do that with the window
|
||||
;; manager, not with Emacs.
|
||||
;; Secondly, the buffer has not been displayed yet,
|
||||
;; so we don't know whether its frame will be selected.
|
||||
(cons (selected-window) t))
|
||||
(display-buffer-reuse-frames
|
||||
(cons (selected-window) 'quit-window))
|
||||
((not (one-window-p t))
|
||||
(cons (selected-window) 'quit-window))
|
||||
(pop-up-windows
|
||||
(cons (selected-window) t))
|
||||
(t
|
||||
(list (selected-window) (window-buffer)
|
||||
(window-start) (window-point)))))
|
||||
(funcall output-function)))))
|
||||
|
||||
(defmacro with-sclang-browser (buffer-name &rest body)
|
||||
`(sclang-display-browser ,buffer-name (lambda () ,@body)))
|
||||
|
||||
;; =====================================================================
|
||||
;; module setup
|
||||
;; =====================================================================
|
||||
|
||||
(provide 'sclang-browser)
|
||||
|
||||
;; EOF
|
||||
20
el/sclang-document.el
Normal file
20
el/sclang-document.el
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
;; copyright 2003 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
|
||||
|
||||
(provide 'sclang-document)
|
||||
|
||||
;; EOF
|
||||
651
el/sclang-help.el
Normal file
651
el/sclang-help.el
Normal file
|
|
@ -0,0 +1,651 @@
|
|||
;; copyright 2003 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)
|
||||
(require 'font-lock))
|
||||
|
||||
;; (require 'w3m) ;; not needed during compilation
|
||||
(require 'sclang-util)
|
||||
(require 'sclang-interp)
|
||||
(require 'sclang-language)
|
||||
(require 'sclang-mode)
|
||||
(require 'sclang-vars)
|
||||
(require 'sclang-minor-mode)
|
||||
|
||||
(defcustom sclang-help-directory "~/SuperCollider/Help"
|
||||
"*Directory where the SuperCollider help files are kept. OBSOLETE."
|
||||
:group 'sclang-interface
|
||||
:version "21.3"
|
||||
:type 'directory
|
||||
:options '(:must-match))
|
||||
|
||||
(defcustom sclang-help-path (list sclang-system-help-dir
|
||||
"~/share/SuperCollider/Help")
|
||||
"*List of directories where SuperCollider help files are kept."
|
||||
:group 'sclang-interface
|
||||
:version "21.4"
|
||||
:type '(repeat directory))
|
||||
|
||||
(defconst sclang-extension-path (list sclang-system-extension-dir
|
||||
"~/share/SuperCollider/Extensions")
|
||||
"List of SuperCollider extension directories.")
|
||||
|
||||
(defcustom sclang-help-fill-column fill-column
|
||||
"*Column beyond which automatic line-wrapping in RTF help files should happen."
|
||||
:group 'sclang-interface
|
||||
:version "21.3"
|
||||
:type 'integer)
|
||||
|
||||
(defcustom sclang-rtf-editor-program "ted"
|
||||
"*Name of an RTF editor program used to edit SuperCollider help files."
|
||||
:group 'sclang-programs
|
||||
:version "21.3"
|
||||
:type 'string)
|
||||
|
||||
(defcustom sclang-html-editor-program "html"
|
||||
"*Name of an HTML editor program used to edit SuperCollider help files."
|
||||
:group 'sclang-programs
|
||||
:version "21.3"
|
||||
:type 'string)
|
||||
|
||||
;; dynamically change certain html-tags when displaying in w3m-browser:
|
||||
|
||||
(defcustom sclang-help-filters
|
||||
'(("p\\.p\\([0-9]+\\)" . "#p\\1")
|
||||
("<p class=\"\\(.*\\)\">\\(.*\\)</p>" . "<div id=\"\\1\">\\2</div>"))
|
||||
"list of pairs of (regexp . filter) defining html-tags to be replaced by the function sclang-help-substitute-for-filters"
|
||||
:group 'sclang-interface
|
||||
:type '(repeat (cons (string :tag "match") (string :tag "replacement"))))
|
||||
|
||||
(defun sclang-help-substitute-for-filters (&rest args)
|
||||
"substitute various tags in SCs html-docs"
|
||||
(mapcar #'(lambda (filter)
|
||||
(let ((regexp (car filter))
|
||||
(to-string (cdr filter)))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward regexp nil t)
|
||||
(replace-match to-string nil nil))))
|
||||
sclang-help-filters))
|
||||
|
||||
;; w3m's content-filtering system
|
||||
(setq w3m-use-filter t)
|
||||
|
||||
(eval-after-load "w3m-filter"
|
||||
'(add-to-list 'w3m-filter-rules
|
||||
;; run on all files read by w3m...
|
||||
'(".*" sclang-help-substitute-for-filters)))
|
||||
|
||||
|
||||
;; dynamically change certain html-tags when displaying in w3m-browser:
|
||||
|
||||
(defcustom sclang-help-filters
|
||||
'(("p\\.p\\([0-9]+\\)" . "#p\\1")
|
||||
("<p class=\"\\(.*\\)\">\\(.*\\)</p>" . "<div id=\"\\1\">\\2</div>"))
|
||||
"list of pairs of (regexp . filter) defining html-tags to be replaced by the function sclang-help-substitute-for-filters"
|
||||
:group 'sclang-interface
|
||||
:type '(repeat (cons (string :tag "match") (string :tag "replacement"))))
|
||||
|
||||
(defun sclang-help-substitute-for-filters (&rest args)
|
||||
"substitute various tags in SCs html-docs"
|
||||
(mapcar #'(lambda (filter)
|
||||
(let ((regexp (car filter))
|
||||
(to-string (cdr filter)))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward regexp nil t)
|
||||
(replace-match to-string nil nil))))
|
||||
sclang-help-filters))
|
||||
|
||||
;; w3m's content-filtering system
|
||||
(setq w3m-use-filter t)
|
||||
|
||||
(eval-after-load "w3m-filter"
|
||||
'(add-to-list 'w3m-filter-rules
|
||||
;; run on all files read by w3m...
|
||||
'(".*" sclang-help-substitute-for-filters)))
|
||||
|
||||
|
||||
(defvar sclang-help-topic-alist nil
|
||||
"Alist mapping help topics to file names.")
|
||||
|
||||
(defvar sclang-help-topic-history nil
|
||||
"List of recently invoked help topics.")
|
||||
;; (defvar sclang-help-topic-ring-length 32)
|
||||
;; (defvar sclang-help-topic-ring (make-ring sclang-help-topic-ring-length))
|
||||
|
||||
(defconst sclang-special-help-topics
|
||||
'(("/" . "division")
|
||||
("-" . "subtraction"))
|
||||
"Alist of help topics with transcoded filenames.")
|
||||
|
||||
(defvar sclang-help-file nil)
|
||||
(defvar sclang-current-help-file nil)
|
||||
(make-variable-buffer-local 'sclang-help-file)
|
||||
|
||||
(defconst sclang-help-file-regexp
|
||||
"\\(\\(\\(\\.help\\)?\\.\\(rtf\\|scd\\|html\\|htm\\)\\)\\|\\(\\.help\\.sc\\.html\\.htm\\)\\|\\.rtfd/TXT\\.rtf\\.html\\.htm\\)$"
|
||||
"Regular expression matching help files.")
|
||||
|
||||
;; =====================================================================
|
||||
;; utilities
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-get-help-file (topic)
|
||||
(let ((topic (or (cdr (assoc topic sclang-special-help-topics)) topic)))
|
||||
(cdr (assoc topic sclang-help-topic-alist))))
|
||||
|
||||
(defun sclang-get-help-topic (file)
|
||||
(let ((topic (car (rassoc file sclang-help-topic-alist))))
|
||||
(or (car (rassoc topic sclang-special-help-topics)) topic)))
|
||||
|
||||
(defun sclang-help-buffer-name (topic)
|
||||
(sclang-make-buffer-name (concat "Help:" topic)))
|
||||
|
||||
(defun sclang-rtf-file-p (file-name)
|
||||
(let ((case-fold-search t))
|
||||
(string-match ".*\\.rtf$" file)))
|
||||
|
||||
;; ========= ADDITION for HTML help files
|
||||
(defun sclang-html-file-p (file-name)
|
||||
(let ((case-fold-search t))
|
||||
(string-match ".*\\.html$" file)))
|
||||
|
||||
;; not quite working yet: would be better to combine with sclang-html-file-p
|
||||
;(defun sclang-htm-file-p (file-name)
|
||||
; (let ((case-fold-search t))
|
||||
; (string-match ".*\\.htm$" file)))
|
||||
|
||||
(defun sclang-sc-file-p (file-name)
|
||||
(let ((case-fold-search t))
|
||||
(string-match ".*\\.sc$" file)))
|
||||
|
||||
(defun sclang-scd-file-p (file-name)
|
||||
(let ((case-fold-search t))
|
||||
(string-match ".*\\.scd$" file)))
|
||||
|
||||
(defun sclang-help-file-p (file-name)
|
||||
(string-match sclang-help-file-regexp file-name))
|
||||
|
||||
(defun sclang-help-topic-name (file-name)
|
||||
(if (string-match sclang-help-file-regexp file-name)
|
||||
(cons (file-name-nondirectory (replace-match "" nil nil file-name 1))
|
||||
file-name)))
|
||||
|
||||
;; =====================================================================
|
||||
;; rtf parsing
|
||||
;; =====================================================================
|
||||
|
||||
(defconst sclang-rtf-face-change-token "\0")
|
||||
|
||||
(defun sclang-fill-rtf-syntax-table (table)
|
||||
;; character quote
|
||||
(modify-syntax-entry ?\\ "/" table)
|
||||
(modify-syntax-entry ?\" "." table)
|
||||
(modify-syntax-entry ?\{ "(" table)
|
||||
(modify-syntax-entry ?\} ")" table)
|
||||
(modify-syntax-entry ?\( "." table)
|
||||
(modify-syntax-entry ?\) "." table)
|
||||
(modify-syntax-entry ?\[ "." table)
|
||||
(modify-syntax-entry ?\] "." table)
|
||||
table)
|
||||
|
||||
(defvar sclang-rtf-syntax-table (sclang-fill-rtf-syntax-table (make-syntax-table))
|
||||
"Syntax table used for RTF parsing.")
|
||||
|
||||
(defvar sclang-rtf-font-map '((Helvetica . variable-pitch)
|
||||
(Helvetica-Bold . variable-pitch)
|
||||
(Monaco . nil)))
|
||||
|
||||
(defstruct sclang-rtf-state
|
||||
output font-table font face pos)
|
||||
|
||||
(macrolet ((rtf-p (pos) `(plist-get (text-properties-at ,pos) 'rtf-p)))
|
||||
(defun sclang-rtf-p (pos) (rtf-p pos))
|
||||
(defun sclang-code-p (pos) (not (rtf-p pos))))
|
||||
|
||||
(defmacro with-sclang-rtf-state-output (state &rest body)
|
||||
`(with-current-buffer (sclang-rtf-state-output ,state)
|
||||
,@body))
|
||||
|
||||
(defmacro sclang-rtf-state-add-font (state font-id font-name)
|
||||
`(push (cons ,font-id (intern ,font-name)) (sclang-rtf-state-font-table ,state)))
|
||||
|
||||
(defmacro sclang-rtf-state-apply (state)
|
||||
(let ((pos (gensym))
|
||||
(font (gensym))
|
||||
(face (gensym)))
|
||||
`(with-current-buffer (sclang-rtf-state-output ,state)
|
||||
(let ((,pos (or (sclang-rtf-state-pos ,state) (point-min)))
|
||||
(,font (cdr (assq
|
||||
(cdr (assoc
|
||||
(sclang-rtf-state-font ,state)
|
||||
(sclang-rtf-state-font-table ,state)))
|
||||
sclang-rtf-font-map)))
|
||||
(,face (sclang-rtf-state-face ,state)))
|
||||
(when (> (point) ,pos)
|
||||
(if ,font
|
||||
(add-text-properties
|
||||
,pos (point)
|
||||
(list 'rtf-p t 'rtf-face (append (list ,font) ,face))))
|
||||
(setf (sclang-rtf-state-pos ,state) (point)))))))
|
||||
|
||||
(defmacro sclang-rtf-state-set-font (state font)
|
||||
`(progn
|
||||
(sclang-rtf-state-apply ,state)
|
||||
(setf (sclang-rtf-state-font ,state) ,font)))
|
||||
|
||||
(defmacro sclang-rtf-state-push-face (state face)
|
||||
(let ((list (gensym)))
|
||||
`(let ((,list (sclang-rtf-state-face state)))
|
||||
(sclang-rtf-state-apply ,state)
|
||||
(unless (memq ,face ,list)
|
||||
(setf (sclang-rtf-state-face ,state)
|
||||
(append ,list (list ,face)))))))
|
||||
|
||||
(defmacro sclang-rtf-state-pop-face (state face)
|
||||
(let ((list (gensym)))
|
||||
`(let* ((,list (sclang-rtf-state-face ,state)))
|
||||
(sclang-rtf-state-apply ,state)
|
||||
(setf (sclang-rtf-state-face ,state) (delq ,face ,list)))))
|
||||
|
||||
(defun sclang-parse-rtf (state)
|
||||
(while (not (eobp))
|
||||
(cond ((looking-at "{")
|
||||
;; container
|
||||
(let ((beg (point)))
|
||||
(with-syntax-table sclang-rtf-syntax-table
|
||||
(forward-list 1))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region (1+ beg) (1- (point)))
|
||||
(goto-char (point-min))
|
||||
(sclang-parse-rtf-container state)
|
||||
(widen)))))
|
||||
((or (looking-at "\\\\\\([{}\\\n]\\)")
|
||||
(looking-at "\\\\\\([^\\ \n]+\\) ?"))
|
||||
;; control
|
||||
(let ((end (match-end 0)))
|
||||
(sclang-parse-rtf-control state (match-string 1))
|
||||
(goto-char end)))
|
||||
((looking-at "\\([^{\\\n]+\\)")
|
||||
;; normal text
|
||||
(let ((end (match-end 0))
|
||||
(match (match-string 1)))
|
||||
(with-sclang-rtf-state-output state (insert match))
|
||||
(goto-char end)))
|
||||
(t
|
||||
;; never reached (?)
|
||||
(forward-char 1)))))
|
||||
|
||||
(defun sclang-parse-rtf-container (state)
|
||||
(cond ((looking-at "\\\\rtf1") ; document
|
||||
(goto-char (match-end 0))
|
||||
(sclang-parse-rtf state))
|
||||
((looking-at "\\\\fonttbl") ; font table
|
||||
(goto-char (match-end 0))
|
||||
(while (looking-at "\\\\\\(f[0-9]+\\)[^ ]* \\([^;]*\\);[^\\]*")
|
||||
(sclang-rtf-state-add-font state (match-string 1) (match-string 2))
|
||||
(goto-char (match-end 0))))
|
||||
((looking-at "{\\\\NeXTGraphic \\([^\\]+\\.[a-z]+\\)") ; inline graphic
|
||||
(let* ((file (match-string 1))
|
||||
(image (and file (create-image (expand-file-name file)))))
|
||||
(with-sclang-rtf-state-output
|
||||
state
|
||||
(if image
|
||||
(insert-image image)
|
||||
(sclang-rtf-state-push-face state 'italic)
|
||||
(insert file)
|
||||
(sclang-rtf-state-pop-face state 'italic)))))
|
||||
))
|
||||
|
||||
(defun sclang-parse-rtf-control (state ctrl)
|
||||
(let ((char (aref ctrl 0)))
|
||||
(cond ((memq char '(?{ ?} ?\\))
|
||||
(with-sclang-rtf-state-output state (insert char)))
|
||||
((or (eq char ?\n)
|
||||
(string= ctrl "par"))
|
||||
(sclang-rtf-state-apply state)
|
||||
(with-sclang-rtf-state-output
|
||||
state
|
||||
(when (sclang-rtf-p (line-beginning-position))
|
||||
(fill-region (line-beginning-position) (line-end-position)
|
||||
t t))
|
||||
(insert ?\n)))
|
||||
((string= ctrl "tab")
|
||||
(with-sclang-rtf-state-output state (insert ?\t)))
|
||||
((string= ctrl "b")
|
||||
(sclang-rtf-state-push-face state 'bold))
|
||||
((string= ctrl "b0")
|
||||
(sclang-rtf-state-pop-face state 'bold))
|
||||
((string-match "^f[0-9]+$" ctrl)
|
||||
(sclang-rtf-state-set-font state ctrl))
|
||||
)))
|
||||
|
||||
(defun sclang-convert-rtf-buffer (output)
|
||||
(let ((case-fold-search nil)
|
||||
(fill-column sclang-help-fill-column))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (looking-at "{\\\\rtf1")
|
||||
(let ((state (make-sclang-rtf-state)))
|
||||
(setf (sclang-rtf-state-output state) output)
|
||||
(sclang-parse-rtf state)
|
||||
(sclang-rtf-state-apply state))))))
|
||||
|
||||
;; =====================================================================
|
||||
;; help mode
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-fill-help-syntax-table (table)
|
||||
;; make ?- be part of symbols for selection and sclang-symbol-at-point
|
||||
(modify-syntax-entry ?- "_" table))
|
||||
|
||||
(defun sclang-fill-help-mode-map (map)
|
||||
(define-key map "\C-c}" 'bury-buffer)
|
||||
(define-key map "\C-c\C-v" 'sclang-edit-help-file))
|
||||
|
||||
(defmacro sclang-help-mode-limit-point-to-code (&rest body)
|
||||
(let ((min (gensym))
|
||||
(max (gensym))
|
||||
(res (gensym)))
|
||||
`(if (and (sclang-code-p (point))
|
||||
(not (or (bobp) (eobp)))
|
||||
(sclang-code-p (1- (point)))
|
||||
(sclang-code-p (1+ (point))))
|
||||
(let ((,min (previous-single-property-change (point) 'rtf-p (current-buffer) (point-min)))
|
||||
(,max (next-single-property-change (point) 'rtf-p (current-buffer) (point-max))))
|
||||
(let ((,res (progn ,@body)))
|
||||
(cond ((< (point) ,min) (goto-char ,min) nil)
|
||||
((> (point) ,max) (goto-char ,max) nil)
|
||||
(t ,res)))))))
|
||||
|
||||
(defun sclang-help-mode-beginning-of-defun (&optional arg)
|
||||
(interactive "p")
|
||||
(sclang-help-mode-limit-point-to-code (sclang-beginning-of-defun arg)))
|
||||
|
||||
(defun sclang-help-mode-end-of-defun (&optional arg)
|
||||
(interactive "p")
|
||||
(sclang-help-mode-limit-point-to-code (sclang-end-of-defun arg)))
|
||||
|
||||
(defun sclang-help-mode-fontify-region (start end loudly)
|
||||
(flet ((fontify-code
|
||||
(start end loudly)
|
||||
(funcall 'font-lock-default-fontify-region start end loudly))
|
||||
(fontify-non-code
|
||||
(start end loudly)
|
||||
(while (< start end)
|
||||
(let ((value (plist-get (text-properties-at start) 'rtf-face))
|
||||
(end (next-single-property-change start 'rtf-face (current-buffer) end)))
|
||||
(add-text-properties start end (list 'face (append '(variable-pitch) (list value))))
|
||||
(setq start end)))))
|
||||
(let ((modified (buffer-modified-p)) (buffer-undo-list t)
|
||||
(inhibit-read-only t) (inhibit-point-motion-hooks t)
|
||||
(inhibit-modification-hooks t)
|
||||
deactivate-mark buffer-file-name buffer-file-truename
|
||||
(pos start))
|
||||
(unwind-protect
|
||||
(while (< pos end)
|
||||
(let ((end (next-single-property-change pos 'rtf-p (current-buffer) end)))
|
||||
(if (sclang-rtf-p pos)
|
||||
(fontify-non-code pos end loudly)
|
||||
(fontify-code pos end loudly))
|
||||
(setq pos end)))
|
||||
(when (and (not modified) (buffer-modified-p))
|
||||
(set-buffer-modified-p nil))))))
|
||||
|
||||
|
||||
(defun sclang-help-mode-indent-line ()
|
||||
(if (sclang-code-p (point))
|
||||
(sclang-indent-line)
|
||||
(insert "\t")))
|
||||
|
||||
(define-derived-mode sclang-help-mode sclang-mode "SCLangHelp"
|
||||
"Major mode for displaying SuperCollider help files.
|
||||
\\{sclang-help-mode-map}"
|
||||
(let ((file (or (buffer-file-name)
|
||||
(and (boundp 'sclang-current-help-file)
|
||||
sclang-current-help-file))))
|
||||
(when file
|
||||
(set-visited-file-name nil)
|
||||
(setq buffer-auto-save-file-name nil)
|
||||
(save-excursion
|
||||
(when (sclang-rtf-file-p file)
|
||||
(let ((tmp-buffer (generate-new-buffer " *RTF*"))
|
||||
(modified-p (buffer-modified-p)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(sclang-convert-rtf-buffer tmp-buffer)
|
||||
(erase-buffer)
|
||||
(insert-buffer-substring tmp-buffer))
|
||||
(and (buffer-modified-p) (not modified-p) (set-buffer-modified-p nil))
|
||||
(kill-buffer tmp-buffer))))))
|
||||
(set (make-local-variable 'sclang-help-file) file)
|
||||
(setq font-lock-defaults
|
||||
(append font-lock-defaults
|
||||
'((font-lock-fontify-region-function . sclang-help-mode-fontify-region))))
|
||||
(set (make-local-variable 'beginning-of-defun-function) 'sclang-help-mode-beginning-of-defun)
|
||||
(set (make-local-variable 'indent-line-function) 'sclang-help-mode-indent-line)
|
||||
))
|
||||
|
||||
;; =====================================================================
|
||||
;; help file access
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-skip-help-directory-p (path)
|
||||
"Answer t if PATH should be skipped during help file indexing."
|
||||
(let ((directory (file-name-nondirectory path)))
|
||||
(reduce (lambda (a b) (or a b))
|
||||
(mapcar (lambda (regexp) (string-match regexp directory))
|
||||
'("^\.$" "^\.\.$" "^CVS$" "^\.svn$" "^_darcs$")))))
|
||||
|
||||
(defun sclang-filter-help-directories (list)
|
||||
"Remove paths to be skipped from LIST of directories."
|
||||
(remove-if (lambda (x)
|
||||
(or (not (file-directory-p x))
|
||||
(sclang-skip-help-directory-p x)))
|
||||
list))
|
||||
|
||||
(defun sclang-directory-files-save (directory &optional full match nosort)
|
||||
"Return a list of names of files in DIRECTORY, or nil on error."
|
||||
(condition-case nil
|
||||
(directory-files directory full match nosort)
|
||||
(error nil)))
|
||||
|
||||
;; (defun sclang-extension-help-directories ()
|
||||
;; "Build a list of help directories for extensions."
|
||||
;; (flet ((flatten (seq)
|
||||
;; (if (null seq)
|
||||
;; seq
|
||||
;; (if (listp seq)
|
||||
;; (reduce 'append (mapcar #'flatten seq))
|
||||
;; (list seq)))))
|
||||
;; (flatten
|
||||
;; (mapcar
|
||||
;; (lambda (dir)
|
||||
;; (mapcar
|
||||
;; (lambda (dir)
|
||||
;; (remove-if-not
|
||||
;; 'file-directory-p
|
||||
;; (sclang-directory-files-save dir t "^[Hh][Ee][Ll][Pp]$" t)))
|
||||
;; (sclang-filter-help-directories (sclang-directory-files-save dir t))))
|
||||
;; sclang-extension-path))))
|
||||
|
||||
;; (defun sclang-help-directories ()
|
||||
;; "Answer list of help directories to be indexed."
|
||||
;; (append sclang-help-path (sclang-extension-help-directories)))
|
||||
|
||||
(defun sclang-help-directories ()
|
||||
"Answer list of help directories to be indexed."
|
||||
(append sclang-help-path sclang-extension-path))
|
||||
|
||||
(defun sclang-make-help-topic-alist (dirs result)
|
||||
"Build a help topic alist from directories in DIRS, with initial RESULT."
|
||||
(if dirs
|
||||
(let* ((files (sclang-directory-files-save (car dirs) t))
|
||||
(topics (remove-if 'null (mapcar 'sclang-help-topic-name files)))
|
||||
(new-dirs (sclang-filter-help-directories files)))
|
||||
(sclang-make-help-topic-alist
|
||||
(append new-dirs (cdr dirs))
|
||||
(append topics result)))
|
||||
(sort result (lambda (a b) (string< (car a) (car b))))))
|
||||
|
||||
(defun sclang-index-help-topics ()
|
||||
"Build an index of help topics searching in the various help file locations."
|
||||
(interactive)
|
||||
(setq sclang-help-topic-alist nil)
|
||||
(let ((case-fold-search nil)
|
||||
(max-specpdl-size 10000)
|
||||
(max-lisp-eval-depth 10000))
|
||||
(sclang-message "Indexing help topics ...")
|
||||
(setq sclang-help-topic-alist
|
||||
(sclang-make-help-topic-alist (sclang-help-directories) nil))
|
||||
(sclang-message "Indexing help topics ... Done")))
|
||||
|
||||
(defun sclang-edit-html-help-file ()
|
||||
"Edit the help file associated with the current buffer.
|
||||
Switches w3m to edit mode (actually HTML mode)."
|
||||
(interactive)
|
||||
(w3m-edit-current-url)
|
||||
)
|
||||
|
||||
(defun sclang-edit-help-code ()
|
||||
"Edit the help file to make code variations.
|
||||
Switches to text mode with sclang-minor-mode."
|
||||
(interactive)
|
||||
(w3m-copy-buffer)
|
||||
;; (text-mode)
|
||||
(sclang-mode)
|
||||
(toggle-read-only)
|
||||
(rename-buffer "*SC_Help:CodeEdit*")
|
||||
)
|
||||
|
||||
|
||||
(defun sclang-edit-help-file ()
|
||||
"Edit the help file associated with the current buffer.
|
||||
Either visit file internally (.sc) or start external editor (.rtf)."
|
||||
(interactive)
|
||||
(if (and (boundp 'sclang-help-file) sclang-help-file)
|
||||
(let ((file sclang-help-file))
|
||||
(if (file-exists-p file)
|
||||
(if (sclang-rtf-file-p file)
|
||||
(start-process (sclang-make-buffer-name (format "HelpEditor:%s" file))
|
||||
nil sclang-rtf-editor-program file)
|
||||
(find-file file))
|
||||
(if (sclang-html-file-p file)
|
||||
(w3m-edit-current-url)
|
||||
;; (find-file file)
|
||||
)
|
||||
(sclang-message "Help file not found")))
|
||||
(sclang-message "Buffer has no associated help file")))
|
||||
|
||||
(defun sclang-help-topic-at-point ()
|
||||
"Answer the help topic at point, or nil if not found."
|
||||
(save-excursion
|
||||
(with-syntax-table sclang-help-mode-syntax-table
|
||||
(let (beg end)
|
||||
(skip-syntax-backward "w_")
|
||||
(setq beg (point))
|
||||
(skip-syntax-forward "w_")
|
||||
(setq end (point))
|
||||
(goto-char beg)
|
||||
(car (assoc (buffer-substring-no-properties beg end)
|
||||
sclang-help-topic-alist))))))
|
||||
|
||||
(defun sclang-goto-help-browser ()
|
||||
"Switch to the *w3m* buffer to browse help files"
|
||||
(interactive)
|
||||
(let* ((buffer-name "*w3m*")
|
||||
(buffer (get-buffer buffer-name)))
|
||||
(if buffer
|
||||
(switch-to-buffer buffer)
|
||||
;; else
|
||||
(let* ((buffer-name "*SC_Help:w3m*")
|
||||
(buffer2 (get-buffer buffer-name)))
|
||||
(if buffer2
|
||||
(switch-to-buffer buffer2)
|
||||
;; else
|
||||
(sclang-find-help "Help")
|
||||
)
|
||||
)
|
||||
)
|
||||
(if buffer
|
||||
(with-current-buffer buffer
|
||||
(rename-buffer "*SC_Help:w3m*")
|
||||
(sclang-help-minor-mode)
|
||||
;;(setq buffer-read-only false)
|
||||
)
|
||||
)
|
||||
; (if buffer
|
||||
;
|
||||
; )
|
||||
)
|
||||
)
|
||||
|
||||
(defun sclang-find-help (topic)
|
||||
(interactive
|
||||
(list
|
||||
(let ((topic (or (and mark-active (buffer-substring-no-properties (region-beginning) (region-end)))
|
||||
(sclang-help-topic-at-point)
|
||||
"Help")))
|
||||
(completing-read (format "Help topic%s: " (if (sclang-get-help-file topic)
|
||||
(format " (default %s)" topic) ""))
|
||||
sclang-help-topic-alist nil t nil 'sclang-help-topic-history topic))))
|
||||
(let ((file (sclang-get-help-file topic)))
|
||||
(if file
|
||||
(if (file-exists-p file)
|
||||
(let* ((buffer-name (sclang-help-buffer-name topic))
|
||||
(buffer (get-buffer buffer-name)))
|
||||
(unless buffer
|
||||
(if (sclang-html-file-p file)
|
||||
(w3m-find-file file)
|
||||
;; (sclang-goto-help-browser)
|
||||
;; not a sclang-html file
|
||||
(setq buffer (get-buffer-create buffer-name))
|
||||
(with-current-buffer buffer
|
||||
(insert-file-contents file)
|
||||
(let ((sclang-current-help-file file)
|
||||
(default-directory (file-name-directory file)))
|
||||
(sclang-help-mode))
|
||||
(set-buffer-modified-p nil)))
|
||||
(switch-to-buffer buffer))
|
||||
(if (sclang-html-file-p file)
|
||||
(sclang-goto-help-browser))
|
||||
)
|
||||
(sclang-message "Help file not found") nil)
|
||||
(sclang-message "No help for \"%s\"" topic) nil)))
|
||||
|
||||
;; =====================================================================
|
||||
;; module setup
|
||||
;; =====================================================================
|
||||
|
||||
(add-hook 'sclang-library-startup-hook (lambda ()
|
||||
(condition-case nil
|
||||
(sclang-index-help-topics)
|
||||
(error nil))))
|
||||
(add-to-list 'auto-mode-alist '("\\.rtf$" . sclang-help-mode))
|
||||
;; ========= ADDITION for HTML help files?? ============
|
||||
;; (add-to-list 'auto-mode-alist '("\\.html$" . sclang-help-mode))
|
||||
;; (setq mm-text-html-renderer 'w3m)
|
||||
;; (setq mm-inline-text-html-with-images t)
|
||||
;; (setq mm-inline-text-html-with-w3m-keymap nil)
|
||||
;; =====================================================
|
||||
(sclang-fill-help-syntax-table sclang-help-mode-syntax-table)
|
||||
(sclang-fill-help-mode-map sclang-help-mode-map)
|
||||
|
||||
(provide 'sclang-help)
|
||||
|
||||
;; EOF
|
||||
713
el/sclang-interp.el
Normal file
713
el/sclang-interp.el
Normal file
|
|
@ -0,0 +1,713 @@
|
|||
;; 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
|
||||
42
el/sclang-keys.el
Normal file
42
el/sclang-keys.el
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
;; copyright 2003 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
|
||||
|
||||
;; (defvar sclang-key-table (make-char-table 'foo))
|
||||
|
||||
;; (defun sclang-define-key (char beg end)
|
||||
;; (interactive)
|
||||
;; (sclang-eval-string (sclang-format "Emacs.defineKey(%o, %o)" char code))
|
||||
;; (define-key (char-to-string char) sclang-key-mode-map 'sclang-execute-key))
|
||||
|
||||
;; (defun sclang-execute-key (char)
|
||||
;; (sclang-eval-string (sclang-format "Emacs.executeKey(%o)" char)))
|
||||
|
||||
(require 'sclang-interp)
|
||||
|
||||
(defun sclang-read-keys ()
|
||||
(interactive)
|
||||
(let (char)
|
||||
(clear-this-command-keys)
|
||||
(while t
|
||||
(setq char (read-event))
|
||||
(clear-this-command-keys)
|
||||
(when (char-valid-p char)
|
||||
(message "%s (%d)" (char-to-string char) char)
|
||||
(sclang-eval-string (format "Emacs.keys.at(%d).value(%d)" char char))))))
|
||||
|
||||
;; EOF
|
||||
|
||||
804
el/sclang-language.el
Normal file
804
el/sclang-language.el
Normal file
|
|
@ -0,0 +1,804 @@
|
|||
;; 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))
|
||||
|
||||
(require 'sclang-browser)
|
||||
(require 'sclang-interp)
|
||||
(require 'sclang-util)
|
||||
|
||||
;; =====================================================================
|
||||
;; regexp utilities
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-regexp-group (regexp &optional addressable)
|
||||
"Enclose REGEXP in grouping parentheses.
|
||||
|
||||
If ADDRESSABLE is non-nil the group match data can be addressed
|
||||
separately after matching."
|
||||
(concat "\\(" (unless addressable "?:") regexp "\\)"))
|
||||
|
||||
(defun sclang-regexp-concat (&rest regexps)
|
||||
"Concatenate REGEXPS by grouping.
|
||||
|
||||
The expressions are joined as alternatives with the \\| operator."
|
||||
(mapconcat 'sclang-regexp-group regexps "\\|"))
|
||||
|
||||
;; =====================================================================
|
||||
;; some useful regular expressions
|
||||
;; =====================================================================
|
||||
|
||||
(defconst sclang-symbol-regexp
|
||||
"\\(?:\\sw\\|\\s_\\)*"
|
||||
"Regular expression matching symbols.")
|
||||
|
||||
(defconst sclang-identifier-regexp
|
||||
(concat "[a-z]" sclang-symbol-regexp)
|
||||
"Regular expression matching valid identifiers.")
|
||||
|
||||
(defconst sclang-method-name-special-chars
|
||||
"-!%&*+/<=>?@|"
|
||||
"Regular expression matching special method name characters.")
|
||||
|
||||
(defconst sclang-method-name-plain-regexp
|
||||
(concat sclang-identifier-regexp "_?")
|
||||
"Regular expression matching regular method names.")
|
||||
|
||||
(defconst sclang-method-name-special-regexp
|
||||
(concat
|
||||
"[" (regexp-quote sclang-method-name-special-chars) "]+")
|
||||
"Regular expression matching method names composed of special characters.")
|
||||
|
||||
(defconst sclang-method-name-regexp
|
||||
(sclang-regexp-concat
|
||||
sclang-method-name-special-regexp
|
||||
sclang-method-name-plain-regexp)
|
||||
"Regular expression matching method names.")
|
||||
|
||||
(defconst sclang-class-name-regexp
|
||||
"\\(?:Meta_\\)?[A-Z]\\(?:\\sw\\|\\s_\\)*"
|
||||
"Regular expression matching class names.")
|
||||
|
||||
(defconst sclang-primitive-name-regexp
|
||||
(concat "_[A-Z]" sclang-symbol-regexp)
|
||||
"Regular expression matching primitive names.")
|
||||
|
||||
(defconst sclang-symbol-name-regexp
|
||||
(sclang-regexp-concat
|
||||
sclang-method-name-regexp
|
||||
sclang-class-name-regexp)
|
||||
"Regular expression matching class and method names.")
|
||||
|
||||
(defconst sclang-class-definition-regexp
|
||||
(concat "^\\s *\\("
|
||||
sclang-class-name-regexp
|
||||
"\\)\\(?:\\s *:\\s *\\("
|
||||
sclang-class-name-regexp
|
||||
"\\)\\)?[[:space:]]*{")
|
||||
"Regular expression matching class definitions.")
|
||||
|
||||
(defconst sclang-method-definition-regexp
|
||||
(concat "^\\s *\\*?\\(" sclang-method-name-regexp "\\)\\s *{")
|
||||
"Regular expression matching method definitions.")
|
||||
|
||||
(defconst sclang-block-regexp
|
||||
"^\\((\\)\\s *\\(?:/[/*]?.*\\)?"
|
||||
"Regular expression matching the beginning of a code block.
|
||||
|
||||
A block is enclosed by parentheses where the opening parenthesis must
|
||||
be at the beginning of a line to avoid ambiguities.")
|
||||
|
||||
(defconst sclang-beginning-of-defun-regexp
|
||||
(sclang-regexp-concat
|
||||
sclang-class-definition-regexp
|
||||
sclang-block-regexp)
|
||||
"Regular expression matching the beginning of defuns.
|
||||
|
||||
The match is either the start of a class definition
|
||||
\(`sclang-class-definition-regexp') or the beginning of a code block
|
||||
enclosed by parenthesis (`sclang-block-regexp').")
|
||||
|
||||
(defconst sclang-method-definition-spec-regexp
|
||||
(concat (sclang-regexp-group sclang-class-name-regexp t)
|
||||
"-"
|
||||
(sclang-regexp-group sclang-method-name-regexp t))
|
||||
"Regular expression matching definition specifications.
|
||||
|
||||
A specification is of the form <class-name>-<method-name>.")
|
||||
|
||||
;; =====================================================================
|
||||
;; regexp building
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-make-class-definition-regexp (name)
|
||||
"Return a regular expression matching the class definition NAME."
|
||||
(concat "\\(" (regexp-quote name) "\\)"
|
||||
"\\(?:\\s *:\\s *\\(" sclang-class-name-regexp "\\)\\)?"
|
||||
"[[:space:]]*{"))
|
||||
|
||||
(defun sclang-make-class-extension-regexp (name)
|
||||
"Return a regular expression matching the class extension NAME."
|
||||
(concat "\\+\\s *\\(" (regexp-quote name) "\\)"
|
||||
"\\s *{"))
|
||||
|
||||
(defun sclang-make-method-definition-regexp (name)
|
||||
"Return a regular expression matching the method definition NAME."
|
||||
(concat "\\(" (regexp-quote name) "\\)\\s *{"))
|
||||
|
||||
;; =====================================================================
|
||||
;; string matching
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-string-match (regexp string)
|
||||
"Match REGEXP with STRING while preserving case."
|
||||
(let ((case-fold-search nil))
|
||||
(string-match regexp string)))
|
||||
|
||||
(defun sclang-symbol-match (symbol-regexp string)
|
||||
(sclang-string-match (concat "^" symbol-regexp "$") string))
|
||||
|
||||
;; =====================================================================
|
||||
;; symbol name predicates
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-class-name-p (string)
|
||||
(sclang-symbol-match sclang-class-name-regexp string))
|
||||
|
||||
(defun sclang-meta-class-name-p (string)
|
||||
(and (sclang-class-name-p string)
|
||||
(sclang-string-match "^Meta_" string)))
|
||||
|
||||
(defun sclang-method-name-p (string)
|
||||
(sclang-symbol-match sclang-method-name-regexp string))
|
||||
|
||||
(defun sclang-symbol-name-p (string)
|
||||
(sclang-symbol-match sclang-symbol-name-regexp string))
|
||||
|
||||
(defun sclang-method-name-setter-p (method-name)
|
||||
(string-match "_$" method-name))
|
||||
|
||||
(defun sclang-method-name-getter-p (method-name)
|
||||
(not (sclang-method-name-setter-p method-name)))
|
||||
|
||||
;; =====================================================================
|
||||
;; symbol name manipulation
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-method-name-setter (method-name)
|
||||
(if (sclang-method-name-setter-p method-name)
|
||||
method-name
|
||||
(concat method-name "_")))
|
||||
|
||||
(defun sclang-method-name-getter (method-name)
|
||||
(if (sclang-method-name-setter-p method-name)
|
||||
(substring method-name 0 (1- (length method-name)))
|
||||
method-name))
|
||||
|
||||
;; =====================================================================
|
||||
;; symbol table access
|
||||
;; =====================================================================
|
||||
|
||||
(defcustom sclang-use-symbol-table t
|
||||
"*Retrieve symbol table upon library initialization.
|
||||
|
||||
Symbol table retrieval is performed each time the library is
|
||||
recompiled. This takes some time and the symbol table has to be held
|
||||
in memory, so it might be necessary to disable this option on
|
||||
low-resource systems."
|
||||
:group 'sclang-interface
|
||||
:version "21.3"
|
||||
:type 'boolean)
|
||||
|
||||
(defvar sclang-symbol-table nil
|
||||
"List of all defined symbols.")
|
||||
|
||||
(defvar sclang-symbol-history nil
|
||||
"List of recent symbols read from the minibuffer.")
|
||||
|
||||
(defvar sclang-symbol-table-file nil)
|
||||
|
||||
(sclang-set-command-handler
|
||||
'symbolTable
|
||||
(lambda (arg)
|
||||
(when (and sclang-use-symbol-table arg)
|
||||
(let ((file sclang-symbol-table-file))
|
||||
(when (and file (file-exists-p file))
|
||||
(with-current-buffer (get-buffer-create (sclang-make-buffer-name "SymbolTable" t))
|
||||
(erase-buffer)
|
||||
(unwind-protect
|
||||
(insert-file-contents file)
|
||||
(delete-file file))
|
||||
(setq sclang-symbol-table-file nil)
|
||||
(goto-char (point-min))
|
||||
(let ((table (condition-case nil
|
||||
(read (current-buffer))
|
||||
(error nil))))
|
||||
(unless table (sclang-message "Couldn't retrieve symbol table."))
|
||||
(setq sclang-symbol-table (sort table 'string<))
|
||||
(sclang-update-font-lock))))))))
|
||||
|
||||
(add-hook 'sclang-library-startup-hook
|
||||
(lambda ()
|
||||
(when sclang-use-symbol-table
|
||||
(let ((file (make-temp-file "sclang-symbol-table.")))
|
||||
(when (and file (file-exists-p file))
|
||||
(setq sclang-symbol-table-file file)
|
||||
(sclang-perform-command 'symbolTable file))))))
|
||||
|
||||
(add-hook 'sclang-library-shutdown-hook
|
||||
(lambda ()
|
||||
(setq sclang-symbol-table nil)
|
||||
(sclang-update-font-lock)))
|
||||
|
||||
(defun sclang-get-symbol-completion-table ()
|
||||
(mapcar (lambda (s) (cons s nil)) sclang-symbol-table))
|
||||
|
||||
(defun sclang-make-symbol-completion-predicate (predicate)
|
||||
(and predicate (lambda (assoc) (funcall predicate (car assoc)))))
|
||||
|
||||
(defun sclang-get-symbol (string)
|
||||
(if (and sclang-use-symbol-table sclang-symbol-table)
|
||||
(car (member string sclang-symbol-table))
|
||||
string))
|
||||
|
||||
(defun sclang-read-symbol (prompt &optional default predicate require-match inherit-input-method)
|
||||
(if sclang-use-symbol-table
|
||||
(flet ((make-minibuffer-local-map
|
||||
(parent-keymap)
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(set-keymap-parent map parent-keymap)
|
||||
;; override keys bound to valid symbols
|
||||
(define-key map [??] 'self-insert-command)
|
||||
map)))
|
||||
(let ((symbol (sclang-get-symbol default))
|
||||
(minibuffer-local-completion-map (make-minibuffer-local-map
|
||||
minibuffer-local-completion-map))
|
||||
(minibuffer-local-must-match-map (make-minibuffer-local-map
|
||||
minibuffer-local-completion-map)))
|
||||
(completing-read (sclang-make-prompt-string prompt symbol)
|
||||
(sclang-get-symbol-completion-table)
|
||||
(sclang-make-symbol-completion-predicate predicate)
|
||||
require-match nil
|
||||
'sclang-symbol-history symbol
|
||||
inherit-input-method)))
|
||||
(read-string (sclang-make-prompt-string prompt default) nil
|
||||
'sclang-symbol-history default inherit-input-method)))
|
||||
|
||||
;; =====================================================================
|
||||
;; buffer movement
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-point-in-comment-p ()
|
||||
"Return non-nil if point is inside a comment.
|
||||
|
||||
Use font-lock information if font-lock-mode is enabled."
|
||||
(if (and (boundp 'font-lock-mode) (eval 'font-lock-mode))
|
||||
;; use available information in font-lock-mode
|
||||
(eq (get-text-property (point) 'face) 'font-lock-comment-face)
|
||||
;; else parse from the beginning
|
||||
(save-excursion
|
||||
(let ((beg (point)))
|
||||
(beginning-of-defun)
|
||||
(not (null (nth 4 (parse-partial-sexp (point) beg))))))))
|
||||
|
||||
(defun sclang-beginning-of-defun (&optional arg)
|
||||
(interactive "p")
|
||||
(let ((case-fold-search nil)
|
||||
(arg (or arg (prefix-numeric-value current-prefix-arg)))
|
||||
(orig (point))
|
||||
(success t))
|
||||
(while (and success (> arg 0))
|
||||
(setq success (re-search-backward sclang-beginning-of-defun-regexp
|
||||
nil 'move))
|
||||
(when (and success (not (sclang-point-in-comment-p)))
|
||||
(goto-char (match-beginning 0))
|
||||
(setq arg (1- arg))))
|
||||
(while (and success (< arg 0))
|
||||
(setq success (re-search-forward sclang-beginning-of-defun-regexp nil t))
|
||||
(when (and success (not (sclang-point-in-comment-p)))
|
||||
(goto-char (match-end 0))
|
||||
(setq arg (1+ arg))))
|
||||
(when success
|
||||
(beginning-of-line)
|
||||
(cond ((looking-at sclang-block-regexp) (goto-char (1- (match-end 1))))
|
||||
((looking-at sclang-class-definition-regexp) (goto-char (1- (match-end 0)))))
|
||||
t)))
|
||||
|
||||
(defun sclang-point-in-defun-p ()
|
||||
"Return non-nil if point is inside a defun.
|
||||
Return value is nil or (beg end) of defun."
|
||||
(save-excursion
|
||||
(let ((orig (point))
|
||||
beg end)
|
||||
(and (progn (beginning-of-defun-raw 1) t)
|
||||
(setq beg (point))
|
||||
(condition-case nil (forward-list 1) (error nil))
|
||||
(setq end (point))
|
||||
(> (point) orig)
|
||||
(list beg end)))))
|
||||
|
||||
(defun sclang-end-of-defun (&optional arg)
|
||||
(interactive "p")
|
||||
(let ((case-fold-search nil)
|
||||
(arg (or arg (prefix-numeric-value current-prefix-arg)))
|
||||
(success t)
|
||||
n cur)
|
||||
(while (and success (> arg 0))
|
||||
(setq n (if (sclang-point-in-defun-p) 1 -1))
|
||||
(setq cur (point))
|
||||
(if (and (sclang-beginning-of-defun n)
|
||||
(condition-case nil (forward-list 1) (error nil)))
|
||||
(progn
|
||||
(setq arg (1- arg)))
|
||||
(goto-char cur)
|
||||
(setq success nil)))
|
||||
(while (and success (< arg 0))
|
||||
(setq n (if (sclang-point-in-defun-p) 2 1))
|
||||
(setq cur (point))
|
||||
(if (and (sclang-beginning-of-defun n)
|
||||
(condition-case nil (forward-list 1) (error nil)))
|
||||
(progn
|
||||
(backward-char 1)
|
||||
(setq arg (1+ arg)))
|
||||
(goto-char cur)
|
||||
(setq success nil)))
|
||||
(when success
|
||||
(forward-line 1) t)))
|
||||
|
||||
;; =====================================================================
|
||||
;; buffer object access
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-symbol-at-point (&optional symbol-name-regexp)
|
||||
"Return the symbol at point, or nil if not a valid symbol.
|
||||
|
||||
The argument SYMBOL-NAME-REGEXP can be used to specify the type of
|
||||
symbol matched, candidates are `sclang-symbol-name-regexp' and
|
||||
`sclang-primitive-name-regexp', the default is
|
||||
`sclang-symbol-name-regexp'."
|
||||
(save-excursion
|
||||
(with-syntax-table sclang-mode-syntax-table
|
||||
(let ((case-fold-search nil)
|
||||
beg end)
|
||||
(cond ((looking-at sclang-method-name-special-regexp)
|
||||
(skip-chars-backward sclang-method-name-special-chars)
|
||||
(setq beg (point))
|
||||
(skip-chars-forward sclang-method-name-special-chars)
|
||||
(setq end (point)))
|
||||
(t
|
||||
(skip-syntax-backward "w_")
|
||||
(setq beg (point))
|
||||
(skip-syntax-forward "w_")
|
||||
(setq end (point))))
|
||||
(goto-char beg)
|
||||
(if (looking-at (or symbol-name-regexp sclang-symbol-name-regexp))
|
||||
(buffer-substring-no-properties beg end))))))
|
||||
|
||||
(defun sclang-line-at-point ()
|
||||
"Return the line at point."
|
||||
(buffer-substring-no-properties (line-beginning-position) (line-end-position)))
|
||||
|
||||
(defun sclang-defun-at-point ()
|
||||
"Return the defun at point.
|
||||
|
||||
A defun may either be a class definition or a code block, see
|
||||
`sclang-beginning-of-defun-regexp'."
|
||||
(save-excursion
|
||||
(with-syntax-table sclang-mode-syntax-table
|
||||
(multiple-value-bind (beg end) (sclang-point-in-defun-p)
|
||||
(and beg end (buffer-substring-no-properties beg end))))))
|
||||
|
||||
;; =====================================================================
|
||||
;; symbol completion
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-complete-symbol (&optional predicate)
|
||||
"Perform completion on symbol preceding point.
|
||||
Compare that symbol against the known symbols.
|
||||
|
||||
When called from a program, optional arg PREDICATE is a predicate
|
||||
determining which symbols are considered.
|
||||
If PREDICATE is nil, the context determines which symbols are
|
||||
considered. If the symbol starts with an upper case letter,
|
||||
class name completion is performed, otherwise only selector names
|
||||
are considered."
|
||||
(interactive)
|
||||
(let* ((buffer (current-buffer))
|
||||
(end (point))
|
||||
(beg (save-excursion
|
||||
(backward-sexp 1)
|
||||
(skip-syntax-forward "'")
|
||||
(point)))
|
||||
(pattern (buffer-substring-no-properties beg end))
|
||||
(case-fold-search nil)
|
||||
(table (sclang-get-symbol-completion-table))
|
||||
(predicate (or predicate
|
||||
(if (sclang-class-name-p pattern)
|
||||
'sclang-class-name-p
|
||||
'sclang-method-name-p)))
|
||||
(completion (try-completion pattern table (lambda (assoc) (funcall predicate (car assoc))))))
|
||||
(cond ((eq completion t))
|
||||
((null completion)
|
||||
(sclang-message "Can't find completion for '%s'" pattern)
|
||||
(ding))
|
||||
((not (string= pattern completion))
|
||||
(delete-region beg end)
|
||||
(insert completion))
|
||||
(t
|
||||
(sclang-message "Making completion list...")
|
||||
(let* ((list (all-completions pattern table (lambda (assoc) (funcall predicate (car assoc)))))
|
||||
(win (selected-window))
|
||||
(buffer-name (sclang-make-buffer-name "Completions"))
|
||||
(same-window-buffer-names (list buffer-name)))
|
||||
(setq list (sort list 'string<))
|
||||
(with-sclang-browser
|
||||
buffer-name
|
||||
(add-hook 'sclang-browser-show-hook (lambda () (sclang-browser-next-link)))
|
||||
(setq sclang-browser-link-function
|
||||
(lambda (arg)
|
||||
(sclang-browser-quit)
|
||||
(with-current-buffer (car arg)
|
||||
(delete-region (car (cdr arg)) (point))
|
||||
(insert (cdr (cdr arg))))))
|
||||
;; (setq view-exit-action 'kill-buffer)
|
||||
(insert (format "Completions for '%s':\n\n" pattern))
|
||||
(dolist (x list)
|
||||
(insert (sclang-browser-make-link x (cons buffer (cons beg x))))
|
||||
(insert " \n"))))
|
||||
(sclang-message "Making completion list...%s" "done")))))
|
||||
|
||||
;; =====================================================================
|
||||
;; introspection
|
||||
;; =====================================================================
|
||||
|
||||
(defcustom sclang-definition-marker-ring-length 32
|
||||
"*Length of marker ring `sclang-definition-marker-ring'."
|
||||
:group 'sclang-interface
|
||||
:version "21.3"
|
||||
:type 'integer)
|
||||
|
||||
(defvar sclang-definition-marker-ring
|
||||
(make-ring sclang-definition-marker-ring-length)
|
||||
"Ring of markers which are locations from which \\[sclang-find-definitions] was invoked.")
|
||||
|
||||
;; really do that?
|
||||
(add-hook 'sclang-library-startup-hook
|
||||
(lambda ()
|
||||
(setq sclang-definition-marker-ring
|
||||
(make-ring sclang-definition-marker-ring-length))))
|
||||
|
||||
(defun sclang-open-definition (name file pos &optional pos-func)
|
||||
(let ((buffer (find-file file)))
|
||||
(when (bufferp buffer)
|
||||
(with-current-buffer buffer
|
||||
(goto-char (or pos (point-min)))
|
||||
(when (and nil (functionp pos-func))
|
||||
(let ((pos (funcall pos-func name)))
|
||||
(and pos (goto-char pos))))))
|
||||
buffer))
|
||||
|
||||
(defun sclang-pop-definition-mark ()
|
||||
"Pop back to where \\[sclang-find-definition] or \\[sclang-find-reference] was last invoked."
|
||||
(interactive)
|
||||
(unless (ring-empty-p sclang-definition-marker-ring)
|
||||
(let ((marker (ring-remove sclang-definition-marker-ring 0)))
|
||||
(switch-to-buffer (or (marker-buffer marker)
|
||||
(error "The marked buffer has been deleted")))
|
||||
(goto-char (marker-position marker))
|
||||
(set-marker marker nil nil))))
|
||||
|
||||
(defun sclang-browse-definitions (name definitions buffer-name header &optional pos-func)
|
||||
(if (cdr definitions)
|
||||
(let ((same-window-buffer-names (list buffer-name)))
|
||||
(with-sclang-browser
|
||||
buffer-name
|
||||
;; (setq view-exit-action 'kill-buffer)
|
||||
(setq sclang-browser-link-function
|
||||
(lambda (data)
|
||||
(sclang-browser-quit)
|
||||
(apply 'sclang-open-definition data)))
|
||||
(add-hook 'sclang-browser-show-hook (lambda () (sclang-browser-next-link)))
|
||||
(insert header)
|
||||
(insert "\n")
|
||||
(let ((max-width 0)
|
||||
format-string)
|
||||
(dolist (def definitions)
|
||||
(setq max-width (max (length (file-name-nondirectory (nth 1 def))) max-width)))
|
||||
(setq format-string (format "%%-%ds %%s" max-width))
|
||||
(dolist (def definitions)
|
||||
(let ((string (format format-string
|
||||
(propertize (file-name-nondirectory (nth 1 def)) 'face 'bold)
|
||||
(nth 0 def)))
|
||||
(data (list name (nth 1 def) (nth 2 def) pos-func)))
|
||||
(insert (sclang-browser-make-link string data))
|
||||
(insert "\n"))))))
|
||||
;; single definition: jump directly
|
||||
(let ((def (car definitions)))
|
||||
(sclang-open-definition name (nth 1 def) (nth 2 def) pos-func))))
|
||||
|
||||
(defun sclang-find-definitions (name)
|
||||
"Find all definitions of symbol NAME."
|
||||
(interactive
|
||||
(list
|
||||
(if current-prefix-arg
|
||||
(read-string "Find definition: ")
|
||||
(sclang-read-symbol "Find definitions of: "
|
||||
(sclang-symbol-at-point) nil t))))
|
||||
(if (sclang-symbol-match sclang-method-definition-spec-regexp name)
|
||||
(sclang-perform-command 'openDefinition name)
|
||||
(if (sclang-get-symbol name)
|
||||
(progn
|
||||
(ring-insert sclang-definition-marker-ring (point-marker))
|
||||
(if (sclang-class-name-p name)
|
||||
(sclang-perform-command 'classDefinitions name)
|
||||
(sclang-perform-command 'methodDefinitions name)))
|
||||
(sclang-message "'%s' is undefined" name))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'openDefinition
|
||||
(lambda (assoc)
|
||||
(let ((name (car assoc))
|
||||
(data (cdr assoc)))
|
||||
(if data
|
||||
(sclang-open-definition nil (car data) (cadr data))
|
||||
(sclang-message "'%s' is undefined" name)))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'classDefinitions
|
||||
(lambda (assoc)
|
||||
(let ((name (car assoc))
|
||||
(data (cdr assoc)))
|
||||
(if data
|
||||
(sclang-browse-definitions
|
||||
name data
|
||||
"*Definitions*" (format "Definitions of '%s'\n" name)
|
||||
(lambda (name)
|
||||
(let ((case-fold-search nil))
|
||||
;; point is either
|
||||
;; - at a class definition
|
||||
;; - inside a class extension
|
||||
;; so jump to the class name
|
||||
(when (or (looking-at (sclang-make-class-definition-regexp name))
|
||||
(re-search-backward (sclang-make-class-extension-regexp name) nil t))
|
||||
(match-beginning 1)))))
|
||||
(sclang-message "No definitions of '%s'" name)))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'methodDefinitions
|
||||
(lambda (assoc)
|
||||
(let ((name (car assoc))
|
||||
(data (cdr assoc)))
|
||||
(if data
|
||||
(sclang-browse-definitions
|
||||
name data
|
||||
"*Definitions*" (format "Definitions of '%s'\n" name)
|
||||
(lambda (name)
|
||||
(let ((case-fold-search nil))
|
||||
(when (re-search-forward (sclang-make-method-definition-regexp name))
|
||||
(match-beginning 1)))))
|
||||
(sclang-message "No definitions of '%s'" name)))))
|
||||
|
||||
(defun sclang-find-references (name)
|
||||
"Find all references to symbol NAME."
|
||||
(interactive
|
||||
(list
|
||||
(sclang-read-symbol "Find references to: "
|
||||
(sclang-symbol-at-point) nil t)))
|
||||
(if (sclang-get-symbol name)
|
||||
(progn
|
||||
(ring-insert sclang-definition-marker-ring (point-marker))
|
||||
(sclang-perform-command 'methodReferences name))
|
||||
(sclang-message "'%s' is undefined" name)))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'methodReferences
|
||||
(lambda (assoc)
|
||||
(let ((name (car assoc))
|
||||
(data (cdr assoc)))
|
||||
(if data
|
||||
(sclang-browse-definitions
|
||||
name data
|
||||
"*References*" (format "References to '%s'\n" name)
|
||||
(lambda (name)
|
||||
(let ((case-fold-search nil))
|
||||
(when (re-search-forward (regexp-quote name))
|
||||
(match-beginning 0)))))
|
||||
(sclang-message "No references to '%s'" name)))))
|
||||
|
||||
(defun sclang-show-method-args ()
|
||||
"whooha. in full effect."
|
||||
(interactive)
|
||||
(let ((regexp (concat
|
||||
sclang-class-name-regexp
|
||||
"[ \t\n]*\\(?:\\.[ \t\n]*\\("
|
||||
sclang-method-name-regexp
|
||||
"\\)\\)?[ \t\n]*("))
|
||||
(case-fold-search nil)
|
||||
(beg (point)))
|
||||
(save-excursion
|
||||
(while (and (re-search-backward regexp nil t)
|
||||
(let ((class (save-match-data (sclang-get-symbol (sclang-symbol-at-point)))))
|
||||
(goto-char (1- (match-end 0)))
|
||||
(if (condition-case nil
|
||||
(save-excursion
|
||||
(forward-list 1)
|
||||
(> (point) beg))
|
||||
(error t))
|
||||
(let ((method (sclang-get-symbol (or (match-string-no-properties 1) "new"))))
|
||||
(and class method
|
||||
(sclang-perform-command 'methodArgs class method)
|
||||
nil))
|
||||
(goto-char (match-beginning 0)) t)))))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'methodArgs
|
||||
(lambda (args)
|
||||
(and args (message "%s" args))))
|
||||
|
||||
(defun sclang-dump-interface (class)
|
||||
"Dump interface of CLASS."
|
||||
(interactive
|
||||
(list
|
||||
(let* ((symbol (sclang-symbol-at-point))
|
||||
(class (and (sclang-get-symbol symbol)
|
||||
(sclang-class-name-p symbol)
|
||||
symbol)))
|
||||
(sclang-read-symbol "Dump interface of: "
|
||||
class 'sclang-class-name-p t))))
|
||||
(sclang-eval-string (format "%s.dumpFullInterface" class)))
|
||||
|
||||
;; =====================================================================
|
||||
;; cscope interface
|
||||
;; =====================================================================
|
||||
|
||||
(defcustom sclang-source-directory nil
|
||||
"Toplevel SuperCollider source directory.
|
||||
|
||||
This variable is used by `sclang-find-primitive' to locate the cscope
|
||||
database."
|
||||
:group 'sclang-interface
|
||||
:version "21.4.1"
|
||||
:type 'directory
|
||||
:options '(must-match))
|
||||
|
||||
(defun sclang-find-primitive (name)
|
||||
"Find primitive name a cscope database.
|
||||
|
||||
The database is searched in `sclang-source-directory', or the
|
||||
current-directory, iff `sclang-source-directoy' is nil."
|
||||
(interactive
|
||||
(let ((default (sclang-symbol-at-point sclang-primitive-name-regexp)))
|
||||
(list (read-string (sclang-make-prompt-string "Find primitive: " default)
|
||||
nil nil default))))
|
||||
(if (require 'xcscope nil t)
|
||||
(let ((cscope-initial-directory sclang-source-directory))
|
||||
(cscope-find-this-text-string
|
||||
(if (string-match "^_" name) name (concat "_" name))))
|
||||
(sclang-message "cscope not available")))
|
||||
|
||||
;; =====================================================================
|
||||
;; sc-code formatting
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-list-to-string (list)
|
||||
(mapconcat 'sclang-object-to-string list ", "))
|
||||
|
||||
(defconst false 'false)
|
||||
|
||||
(defun sclang-object-to-string (obj)
|
||||
(cond ((null obj)
|
||||
"nil")
|
||||
((eq false obj)
|
||||
"false")
|
||||
((eq t obj)
|
||||
"true")
|
||||
((symbolp obj)
|
||||
(format "'%s'" obj))
|
||||
((listp obj)
|
||||
(format "[ %s ]" (sclang-list-to-string obj)))
|
||||
(t (format "%S" obj))))
|
||||
|
||||
(defun sclang-format (string &rest args)
|
||||
"format chars:
|
||||
%s - print string
|
||||
%o - print object
|
||||
%l - print argument list"
|
||||
(let ((case-fold-search nil)
|
||||
(i 0))
|
||||
(save-match-data
|
||||
(while (and (< i (length string))
|
||||
(string-match "%[los%]" string i))
|
||||
(let* ((start (car (match-data)))
|
||||
(format (aref string (1+ start)))
|
||||
(arg (if args
|
||||
(pop args)
|
||||
(error "Not enough arguments for format string")))
|
||||
(repl (cond ((eq ?o format)
|
||||
(sclang-object-to-string arg))
|
||||
((eq ?l format)
|
||||
(if (listp arg)
|
||||
(sclang-list-to-string arg)
|
||||
(sclang-object-to-string arg)))
|
||||
((eq ?s format)
|
||||
(format "%s" arg))
|
||||
((eq ?% format)
|
||||
(push arg args)
|
||||
"%"))))
|
||||
(setq string (replace-match repl t t string))
|
||||
(setq i (+ start (length repl)))))))
|
||||
string)
|
||||
|
||||
(defun sclang-format-pseq (items)
|
||||
"Format ITEMS (a flat list of numbers or symbols) as a possibly nested Pseq.
|
||||
Looks for all repetitive patterns in ITEMS recursively. Therefore, it is
|
||||
computationally expensive, especially when ITEMS is a long list. If you don't
|
||||
want smart pattern guessing, use `sclang-format' directly to format your Pseq."
|
||||
(flet ((find-reps (items)
|
||||
(let (r)
|
||||
(while items
|
||||
(let ((ret (car items))
|
||||
(skip 1)
|
||||
(rep (length items)))
|
||||
(catch 'match-found
|
||||
(while (>= rep 2)
|
||||
(let ((i (/ (length items) rep)))
|
||||
(while (> i 0)
|
||||
(let ((sublst (subseq items 0 i)))
|
||||
(when (catch 'equal
|
||||
(let ((a items))
|
||||
(loop repeat rep do
|
||||
(let ((b sublst))
|
||||
(while b
|
||||
(unless (eql (car b) (car a))
|
||||
(throw 'equal nil))
|
||||
(setq a (cdr a)
|
||||
b (cdr b)))))
|
||||
t))
|
||||
(setq ret (cons rep (if (> i 5)
|
||||
(find-reps sublst)
|
||||
sublst))
|
||||
skip (* i rep))
|
||||
(throw 'match-found t))
|
||||
(decf i))))
|
||||
(decf rep)))
|
||||
(accept-process-output nil 0 100)
|
||||
(message "Processed...%S" ret) ;; invent better progress info
|
||||
(setq r (append r (list ret))
|
||||
items (nthcdr skip items))))
|
||||
r))
|
||||
(elem-to-string (elem)
|
||||
(cond
|
||||
((consp elem)
|
||||
(concat "Pseq([ "
|
||||
(mapconcat #'elem-to-string (cdr elem) ", ")
|
||||
(format " ], %d)" (car elem))))
|
||||
(t (sclang-object-to-string elem)))))
|
||||
(let ((compressed (find-reps items)))
|
||||
(if (and (= (length compressed) 1) (consp (car compressed)))
|
||||
(elem-to-string (car compressed))
|
||||
(concat "Pseq([ "
|
||||
(mapconcat #'elem-to-string compressed ", ")
|
||||
" ], 1)")))))
|
||||
|
||||
;; =====================================================================
|
||||
;; module setup
|
||||
;; =====================================================================
|
||||
|
||||
(provide 'sclang-language)
|
||||
|
||||
;; EOF
|
||||
23
el/sclang-menu.el
Normal file
23
el/sclang-menu.el
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
;; copyright 2003 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
|
||||
|
||||
;; (sclang-set-command-handler
|
||||
;; '_updateMenu
|
||||
;; (lambda (arg)
|
||||
;; (message "menu: %s" arg)))
|
||||
|
||||
(provide 'sclang-menu)
|
||||
59
el/sclang-minor-mode.el
Normal file
59
el/sclang-minor-mode.el
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
;;; sclang-minor-mode for use in help files
|
||||
;;; SuperCollider
|
||||
;;; (c) 2007, Marije Baalman - nescivi
|
||||
;;; released under GPL
|
||||
|
||||
(easy-mmode-define-minor-mode sclang-minor-mode
|
||||
"Toggle sclang-minor-mode.
|
||||
With no argument, this command toggles the mode.
|
||||
Non-null prefix argument turns on the mode.
|
||||
Null prefix argument turns off the mode.
|
||||
|
||||
When sclang-minor-mode is enabled, you can execute
|
||||
sclang code with the normal command C-c C-c and C-c C-x."
|
||||
;; The initial value.
|
||||
nil
|
||||
;; The indicator for the mode line.
|
||||
" sclang"
|
||||
;; The minor mode bindings.
|
||||
'(("\C-c\C-c" . sclang-eval-region-or-line)
|
||||
("\C-c\C-x" . sclang-eval-region)
|
||||
("\C-\M-x" . sclang-eval-defun)
|
||||
("\C-c\C-h" . sclang-find-help)
|
||||
("\C-\M-h" . sclang-goto-help-browser)
|
||||
("\C-c\C-s" . sclang-main-stop)
|
||||
))
|
||||
|
||||
(provide 'sclang-minor-mode)
|
||||
|
||||
(easy-mmode-define-minor-mode sclang-help-minor-mode
|
||||
"Toggle sclang-minor-mode.
|
||||
With no argument, this command toggles the mode.
|
||||
Non-null prefix argument turns on the mode.
|
||||
Null prefix argument turns off the mode.
|
||||
|
||||
When sclang-help-minor-mode is enabled, you can execute
|
||||
sclang code with the normal command C-c C-c and C-c C-x."
|
||||
;; The initial value.
|
||||
nil
|
||||
;; The indicator for the mode line.
|
||||
" sclang-help"
|
||||
;; The minor mode bindings.
|
||||
'(("\C-c\C-c" . sclang-eval-region-or-line)
|
||||
("\C-c\C-x" . sclang-eval-region)
|
||||
("\C-\M-x" . sclang-eval-defun)
|
||||
("\C-c\C-h" . sclang-find-help)
|
||||
("\C-c\C-s" . sclang-main-stop)
|
||||
("\C-c\C-v" . sclang-edit-html-help-file)
|
||||
("E" . sclang-edit-help-code)
|
||||
))
|
||||
|
||||
(provide 'sclang-help-minor-mode)
|
||||
|
||||
(add-hook 'sclang-help-minor-mode-hook 'sclang-minor-hooks)
|
||||
(add-hook 'sclang-minor-mode-hook 'sclang-minor-hooks)
|
||||
|
||||
(defun sclang-minor-hooks ()
|
||||
(sclang-init-document)
|
||||
(sclang-make-document)
|
||||
)
|
||||
687
el/sclang-mode.el
Normal file
687
el/sclang-mode.el
Normal file
|
|
@ -0,0 +1,687 @@
|
|||
;; 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)
|
||||
(load "cl-seq" nil t)
|
||||
(require 'font-lock))
|
||||
|
||||
(require 'sclang-interp)
|
||||
(require 'sclang-language)
|
||||
|
||||
(defun sclang-fill-syntax-table (table)
|
||||
;; string
|
||||
(modify-syntax-entry ?\" "\"" table)
|
||||
(modify-syntax-entry ?\' "\"" table) ; no string syntax class for single quotes
|
||||
;; expression prefix
|
||||
(modify-syntax-entry ?~ "'" table)
|
||||
;; escape
|
||||
(modify-syntax-entry ?\\ "\\" table)
|
||||
;; character quote
|
||||
(modify-syntax-entry ?$ "/" table)
|
||||
;; symbol
|
||||
(modify-syntax-entry ?_ "_" table)
|
||||
;; symbol/punctuation
|
||||
(modify-syntax-entry ?! "." table)
|
||||
(modify-syntax-entry ?% "." table)
|
||||
(modify-syntax-entry ?& "." table)
|
||||
(modify-syntax-entry ?* ". 23n" table)
|
||||
(modify-syntax-entry ?+ "." table)
|
||||
(modify-syntax-entry ?- "." table)
|
||||
(modify-syntax-entry ?/ ". 124b" table)
|
||||
(modify-syntax-entry ?< "." table)
|
||||
(modify-syntax-entry ?= "." table)
|
||||
(modify-syntax-entry ?> "." table)
|
||||
(modify-syntax-entry ?? "." table)
|
||||
(modify-syntax-entry ?@ "." table)
|
||||
(modify-syntax-entry ?| "." table)
|
||||
;; punctuation
|
||||
(modify-syntax-entry ?: "." table)
|
||||
(modify-syntax-entry ?\; "." table)
|
||||
(modify-syntax-entry ?\^ "." table)
|
||||
;; parenthesis
|
||||
(modify-syntax-entry ?\( "()" table)
|
||||
(modify-syntax-entry ?\) ")(" table)
|
||||
(modify-syntax-entry ?\[ "(]" table)
|
||||
(modify-syntax-entry ?\] ")[" table)
|
||||
(modify-syntax-entry ?\{ "(}" table)
|
||||
(modify-syntax-entry ?\} "){" table)
|
||||
;; comment end
|
||||
(modify-syntax-entry ?\n "> b" table)
|
||||
;; Give CR the same syntax as newline, for selective-display
|
||||
(modify-syntax-entry ?\^m "> b" table)
|
||||
;; return table
|
||||
table)
|
||||
|
||||
(defun sclang-mode-make-menu (title)
|
||||
(easy-menu-create-menu
|
||||
title
|
||||
'(
|
||||
["Start Interpreter" sclang-start :included (not (sclang-library-initialized-p))]
|
||||
["Restart Interpreter" sclang-start :included (sclang-library-initialized-p)]
|
||||
["Stop Interpreter" sclang-stop :included (sclang-get-process)]
|
||||
["Kill Interpreter" sclang-kill :included (sclang-get-process)]
|
||||
"-"
|
||||
["Show Post Buffer" sclang-show-post-buffer]
|
||||
["Clear Post Buffer" sclang-clear-post-buffer]
|
||||
"-"
|
||||
["Switch To Workspace" sclang-switch-to-workspace]
|
||||
"-"
|
||||
["Evaluate Region" sclang-eval-region]
|
||||
["Evaluate Line" sclang-eval-region-or-line]
|
||||
["Evaluate Defun" sclang-eval-defun]
|
||||
["Evaluate Expression ..." sclang-eval-expression]
|
||||
"-"
|
||||
["Find Definitions ..." sclang-find-definitions]
|
||||
["Find References ..." sclang-find-references]
|
||||
["Pop Mark" sclang-pop-definition-mark]
|
||||
["Show Method Arguments" sclang-show-method-args]
|
||||
["Dump Interface" sclang-dump-interface]
|
||||
"-"
|
||||
["Index Help Topics" sclang-index-help-topics]
|
||||
["Find Help ..." sclang-find-help]
|
||||
["Switch to Help Browser" sclang-goto-help-browser]
|
||||
"-"
|
||||
["Run Main" sclang-main-run]
|
||||
["Stop Main" sclang-main-stop]
|
||||
["Show Server Panels" sclang-show-server-panel]
|
||||
)))
|
||||
|
||||
(defun sclang-fill-mode-map (map)
|
||||
;; process control
|
||||
(define-key map "\C-c\C-l" 'sclang-start)
|
||||
;; post buffer control
|
||||
(define-key map "\C-c<" 'sclang-clear-post-buffer)
|
||||
(define-key map "\C-c>" 'sclang-show-post-buffer)
|
||||
;; workspace access
|
||||
(define-key map "\C-c\C-w" 'sclang-switch-to-workspace)
|
||||
;; code evaluation
|
||||
(define-key map "\C-c\C-c" 'sclang-eval-region-or-line)
|
||||
(define-key map "\C-c\C-x" 'sclang-eval-region)
|
||||
(define-key map "\C-\M-x" 'sclang-eval-defun)
|
||||
(define-key map "\C-c\C-e" 'sclang-eval-expression)
|
||||
;; language information
|
||||
(define-key map "\M-\t" 'sclang-complete-symbol)
|
||||
(define-key map "\C-c:" 'sclang-find-definitions)
|
||||
(define-key map "\C-c;" 'sclang-find-references)
|
||||
(define-key map "\C-c}" 'sclang-pop-definition-mark)
|
||||
(define-key map "\C-c\C-m" 'sclang-show-method-args)
|
||||
(define-key map "\C-c{" 'sclang-dump-interface)
|
||||
;; documentation access
|
||||
(define-key map "\C-c\C-h" 'sclang-find-help)
|
||||
(define-key map "\C-\M-h" 'sclang-goto-help-browser)
|
||||
;; language control
|
||||
(define-key map "\C-c\C-r" 'sclang-main-run)
|
||||
(define-key map "\C-c\C-s" 'sclang-main-stop)
|
||||
(define-key map "\C-c\C-p" 'sclang-show-server-panel)
|
||||
;; electric characters
|
||||
(define-key map "}" 'sclang-electric-brace)
|
||||
(define-key map ")" 'sclang-electric-brace)
|
||||
(define-key map "]" 'sclang-electric-brace)
|
||||
(define-key map "/" 'sclang-electric-slash)
|
||||
(define-key map "*" 'sclang-electric-star)
|
||||
;; menu
|
||||
(let ((title "SCLang"))
|
||||
(define-key map [menu-bar sclang] (cons title (sclang-mode-make-menu title))))
|
||||
;; return map
|
||||
map)
|
||||
|
||||
;; =====================================================================
|
||||
;; font-lock support
|
||||
;; =====================================================================
|
||||
|
||||
(defvar sclang-font-lock-keyword-list
|
||||
'(
|
||||
"arg"
|
||||
"classvar"
|
||||
"const"
|
||||
"super"
|
||||
"this"
|
||||
"thisFunction"
|
||||
"thisFunctionDef"
|
||||
"thisMethod"
|
||||
"thisProcess"
|
||||
"thisThread"
|
||||
"var"
|
||||
)
|
||||
"*List of keywords to highlight in SCLang mode.")
|
||||
|
||||
(defvar sclang-font-lock-builtin-list
|
||||
'(
|
||||
"false"
|
||||
"inf"
|
||||
"nil"
|
||||
"true"
|
||||
)
|
||||
"*List of builtins to highlight in SCLang mode.")
|
||||
|
||||
(defvar sclang-font-lock-method-list
|
||||
'(
|
||||
"ar"
|
||||
"for"
|
||||
"forBy"
|
||||
"if"
|
||||
"ir"
|
||||
"kr"
|
||||
"loop"
|
||||
"while"
|
||||
)
|
||||
"*List of methods to highlight in SCLang mode.")
|
||||
|
||||
(defvar sclang-font-lock-error-list
|
||||
'(
|
||||
"die"
|
||||
"error"
|
||||
"exit"
|
||||
"halt"
|
||||
"verboseHalt"
|
||||
"warn"
|
||||
)
|
||||
"*List of methods signalling errors or warnings.")
|
||||
|
||||
(defvar sclang-font-lock-class-keywords nil)
|
||||
|
||||
(defvar sclang-font-lock-keywords-1 nil
|
||||
"Subdued level highlighting for SCLang mode.")
|
||||
|
||||
(defvar sclang-font-lock-keywords-2 nil
|
||||
"Medium level highlighting for SCLang mode.")
|
||||
|
||||
(defvar sclang-font-lock-keywords-3 nil
|
||||
"Gaudy level highlighting for SCLang mode.")
|
||||
|
||||
(defconst sclang-font-lock-keywords nil
|
||||
"Default expressions to highlight in SCLang mode.")
|
||||
|
||||
(defconst sclang-font-lock-defaults '((sclang-font-lock-keywords
|
||||
sclang-font-lock-keywords-1
|
||||
sclang-font-lock-keywords-2
|
||||
sclang-font-lock-keywords-3
|
||||
)
|
||||
nil nil
|
||||
nil
|
||||
beginning-of-defun
|
||||
))
|
||||
|
||||
(defun sclang-font-lock-syntactic-face (state)
|
||||
(cond ((eq (nth 3 state) ?')
|
||||
;; symbol
|
||||
'font-lock-constant-face)
|
||||
((nth 3 state)
|
||||
;; string
|
||||
'font-lock-string-face)
|
||||
((nth 4 state)
|
||||
;; comment
|
||||
'font-lock-comment-face)))
|
||||
|
||||
(defun sclang-font-lock-class-keyword-matcher (limit)
|
||||
(let ((regexp (or sclang-font-lock-class-keywords
|
||||
(concat "\\<" sclang-class-name-regexp "\\>")))
|
||||
(case-fold-search nil))
|
||||
(re-search-forward regexp limit t)))
|
||||
|
||||
(defun sclang-set-font-lock-keywords ()
|
||||
(setq
|
||||
;; level 1
|
||||
sclang-font-lock-keywords-1
|
||||
(list
|
||||
;; keywords
|
||||
(cons (regexp-opt sclang-font-lock-keyword-list'words)
|
||||
'font-lock-keyword-face)
|
||||
;; builtins
|
||||
(cons (regexp-opt sclang-font-lock-builtin-list 'words)
|
||||
'font-lock-builtin-face)
|
||||
;; pi is a special case
|
||||
(cons "\\<\\([0-9]+\\(\\.\\)\\)pi\\>" 'font-lock-builtin-face)
|
||||
;; constants
|
||||
(cons "\\s/\\s\\?." 'font-lock-constant-face) ; characters
|
||||
(cons (concat "\\\\\\(" sclang-symbol-regexp "\\)")
|
||||
'font-lock-constant-face) ; symbols
|
||||
)
|
||||
;; level 2
|
||||
sclang-font-lock-keywords-2
|
||||
(append
|
||||
sclang-font-lock-keywords-1
|
||||
(list
|
||||
;; variables
|
||||
(cons (concat "\\s'\\(" sclang-identifier-regexp "\\)")
|
||||
'font-lock-variable-name-face) ; environment variables
|
||||
(cons (concat "\\<\\(" sclang-identifier-regexp "\\)\\>:") ; keyword arguments
|
||||
'font-lock-variable-name-face)
|
||||
;; method definitions
|
||||
(cons sclang-method-definition-regexp
|
||||
(list 1 'font-lock-function-name-face))
|
||||
;; methods
|
||||
(cons (regexp-opt sclang-font-lock-method-list 'words)
|
||||
'font-lock-function-name-face)
|
||||
;; errors
|
||||
(cons (regexp-opt sclang-font-lock-error-list 'words)
|
||||
'font-lock-warning-face)
|
||||
))
|
||||
;; level 3
|
||||
sclang-font-lock-keywords-3
|
||||
(append
|
||||
sclang-font-lock-keywords-2
|
||||
(list
|
||||
;; classes
|
||||
(cons 'sclang-font-lock-class-keyword-matcher 'font-lock-type-face)
|
||||
;; (cons (concat "\\<" sclang-class-name-regexp "\\>") 'font-lock-type-face)
|
||||
))
|
||||
;; default level
|
||||
sclang-font-lock-keywords sclang-font-lock-keywords-1
|
||||
))
|
||||
|
||||
(defun sclang-update-font-lock ()
|
||||
"Update font-lock information in all sclang-mode buffers."
|
||||
(setq sclang-font-lock-class-keywords
|
||||
(and sclang-symbol-table
|
||||
(let* ((list (remove-if
|
||||
(lambda (x) (or (not (sclang-class-name-p x))
|
||||
(sclang-string-match "^Meta_" x)))
|
||||
sclang-symbol-table))
|
||||
;; need to set this for large numbers of classes
|
||||
(max-specpdl-size (* (length list) 2)))
|
||||
(condition-case nil
|
||||
(concat "\\<\\(?:Meta_\\)?\\(?:" (regexp-opt list) "\\)\\>")
|
||||
(error nil)))))
|
||||
;; too expensive
|
||||
;; (dolist (buffer (buffer-list))
|
||||
;; (with-current-buffer buffer
|
||||
;; (and (eq major-mode 'sclang-mode)
|
||||
;; (eq t (car font-lock-keywords))
|
||||
;; (setq font-lock-keywords (cdr font-lock-keywords)))))
|
||||
(if (eq major-mode 'sclang-mode)
|
||||
(font-lock-fontify-buffer)))
|
||||
|
||||
;; =====================================================================
|
||||
;; indentation
|
||||
;; =====================================================================
|
||||
|
||||
(defcustom sclang-indent-level 4
|
||||
"*Indentation offset for SCLang statements."
|
||||
:group 'sclang-mode
|
||||
:type 'integer)
|
||||
|
||||
(defun sclang-indent-line ()
|
||||
"Indent current line as sclang code.
|
||||
Return the amount the indentation changed by."
|
||||
(let ((indent (calculate-sclang-indent))
|
||||
beg shift-amt
|
||||
(case-fold-search nil)
|
||||
(pos (- (point-max) (point))))
|
||||
(beginning-of-line)
|
||||
(setq beg (point))
|
||||
(skip-chars-forward " \t")
|
||||
(setq shift-amt (- indent (current-column)))
|
||||
(if (zerop shift-amt)
|
||||
(if (> (- (point-max) pos) (point))
|
||||
(goto-char (- (point-max) pos)))
|
||||
(delete-region beg (point))
|
||||
(indent-to indent)
|
||||
;; if initial point was within line's indentation, position
|
||||
;; after the indentation, else stay at same point in text.
|
||||
(if (> (- (point-max) pos) (point))
|
||||
(goto-char (- (point-max) pos))))
|
||||
shift-amt))
|
||||
|
||||
(defun calculate-sclang-indent (&optional parse-start)
|
||||
"Return appropriate indentation for current line as sclang code.
|
||||
Returns the column to indent to."
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(let ((indent-point (point))
|
||||
(case-fold-search nil)
|
||||
state)
|
||||
(if parse-start
|
||||
(goto-char parse-start)
|
||||
(beginning-of-defun))
|
||||
(while (< (point) indent-point)
|
||||
(setq state (parse-partial-sexp (point) indent-point 0)))
|
||||
(let* ((containing-sexp (nth 1 state))
|
||||
(inside-string-p (nth 3 state))
|
||||
(inside-comment-p (nth 4 state)))
|
||||
(cond (inside-string-p
|
||||
;; inside string: no change
|
||||
(current-indentation))
|
||||
((integerp inside-comment-p)
|
||||
;; inside comment
|
||||
(let ((base (if containing-sexp
|
||||
(save-excursion
|
||||
(goto-char containing-sexp)
|
||||
(+ (current-indentation) sclang-indent-level))
|
||||
0))
|
||||
(offset (* sclang-indent-level
|
||||
(- inside-comment-p
|
||||
(if (save-excursion
|
||||
(back-to-indentation)
|
||||
(looking-at "\\*/"))
|
||||
1 0)))))
|
||||
(+ base offset)))
|
||||
((null containing-sexp)
|
||||
;; top-level: no indentation
|
||||
0)
|
||||
(t
|
||||
(back-to-indentation)
|
||||
(let ((open-paren (and (looking-at "\\s)")
|
||||
(matching-paren (char-after))))
|
||||
(indent (current-indentation)))
|
||||
(goto-char containing-sexp)
|
||||
(if (or (not open-paren) (eq open-paren (char-after)))
|
||||
(cond ((progn (beginning-of-line) (looking-at sclang-block-regexp)) 0)
|
||||
(open-paren (current-indentation))
|
||||
(t (+ (current-indentation) sclang-indent-level)))
|
||||
;; paren mismatch: do nothing
|
||||
indent))))))))
|
||||
|
||||
;; =====================================================================
|
||||
;; electric character commands
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-electric-brace (arg)
|
||||
(interactive "*P")
|
||||
(self-insert-command (prefix-numeric-value arg))
|
||||
(and (save-excursion
|
||||
(beginning-of-line)
|
||||
(looking-at "\\s *\\s)"))
|
||||
(indent-according-to-mode)))
|
||||
|
||||
(defun sclang-electric-slash (arg)
|
||||
(interactive "*P")
|
||||
(let* ((char (char-before))
|
||||
(indent-p (or (eq char ?/)
|
||||
(eq char ?*))))
|
||||
(self-insert-command (prefix-numeric-value arg))
|
||||
(if indent-p (indent-according-to-mode))))
|
||||
|
||||
(defun sclang-electric-star (arg)
|
||||
(interactive "*P")
|
||||
(let ((indent-p (eq (char-before) ?/)))
|
||||
(self-insert-command (prefix-numeric-value arg))
|
||||
(if indent-p (indent-according-to-mode))))
|
||||
|
||||
;; =====================================================================
|
||||
;; document interface
|
||||
;; =====================================================================
|
||||
|
||||
(defvar sclang-document-id nil)
|
||||
(defvar sclang-document-state nil)
|
||||
(defvar sclang-document-envir nil)
|
||||
|
||||
(defvar sclang-document-counter 0)
|
||||
(defvar sclang-document-list nil)
|
||||
(defvar sclang-current-document nil
|
||||
"Currently active document.")
|
||||
|
||||
(defvar sclang-document-idle-timer nil)
|
||||
|
||||
(defconst sclang-document-property-map
|
||||
'((sclang-document-name . (prSetTitle (buffer-name)))
|
||||
(sclang-document-path . (prSetFileName (buffer-file-name)))
|
||||
(sclang-document-listener-p . (prSetIsListener (eq (current-buffer) (sclang-get-post-buffer))))
|
||||
(sclang-document-editable-p . (prSetEditable (not buffer-read-only)))
|
||||
(sclang-document-edited-p . (prSetEdited (buffer-modified-p)))))
|
||||
|
||||
(defmacro sclang-next-document-id ()
|
||||
`(incf sclang-document-counter))
|
||||
|
||||
(defun sclang-document-list ()
|
||||
sclang-document-list)
|
||||
|
||||
(defun sclang-document-id (buffer)
|
||||
(cdr (assq 'sclang-document-id (buffer-local-variables buffer))))
|
||||
|
||||
(defun sclang-document-p (buffer)
|
||||
(integerp (sclang-document-id buffer)))
|
||||
|
||||
(defmacro with-sclang-document (buffer &rest body)
|
||||
`(when (sclang-document-p buffer)
|
||||
(with-current-buffer buffer
|
||||
,@body)))
|
||||
|
||||
(defun sclang-get-document (id)
|
||||
(find-if (lambda (doc) (eq id (sclang-document-id doc)))
|
||||
(sclang-document-list)))
|
||||
|
||||
(defun sclang-init-document ()
|
||||
(set (make-local-variable 'sclang-document-id) (sclang-next-document-id))
|
||||
(set (make-local-variable 'sclang-document-envir) nil)
|
||||
(dolist (assoc sclang-document-property-map)
|
||||
(set (make-local-variable (car assoc)) nil))
|
||||
(pushnew (current-buffer) sclang-document-list))
|
||||
|
||||
(defun sclang-document-update-property-1 (assoc &optional force)
|
||||
(when (consp assoc)
|
||||
(let* ((key (car assoc))
|
||||
(prop (cdr assoc))
|
||||
(prev-value (eval key))
|
||||
(cur-value (eval (cadr prop))))
|
||||
(when (or force (not (equal prev-value cur-value)))
|
||||
(set key cur-value)
|
||||
(sclang-perform-command-no-result
|
||||
'documentSetProperty sclang-document-id
|
||||
(car prop) cur-value)))))
|
||||
|
||||
(defun sclang-document-update-property (key &optional force)
|
||||
(sclang-document-update-property-1 (assq key sclang-document-property-map) force))
|
||||
|
||||
(defun sclang-document-update-properties (&optional force)
|
||||
(dolist (assoc sclang-document-property-map)
|
||||
(sclang-document-update-property-1 assoc force)))
|
||||
|
||||
(defun sclang-make-document ()
|
||||
(sclang-perform-command-no-result 'documentNew sclang-document-id)
|
||||
(sclang-document-update-properties t))
|
||||
|
||||
(defun sclang-close-document (buffer)
|
||||
(with-sclang-document
|
||||
buffer
|
||||
(setq sclang-document-list (delq buffer sclang-document-list))
|
||||
(sclang-perform-command-no-result
|
||||
'documentClosed sclang-document-id)))
|
||||
|
||||
(defun sclang-set-current-document (buffer &optional force)
|
||||
(when (or force (not (eq buffer sclang-current-document)))
|
||||
(setq sclang-current-document buffer)
|
||||
(sclang-perform-command-no-result 'documentSetCurrent (sclang-document-id buffer))
|
||||
t))
|
||||
|
||||
(defun sclang-document-library-startup-hook-function ()
|
||||
(dolist (buffer (sclang-document-list))
|
||||
(with-current-buffer buffer
|
||||
(sclang-make-document)))
|
||||
(sclang-set-current-document (current-buffer) t))
|
||||
|
||||
(defun sclang-document-kill-buffer-hook-function ()
|
||||
(sclang-close-document (current-buffer)))
|
||||
|
||||
(defun sclang-document-post-command-hook-function ()
|
||||
(when (and (sclang-library-initialized-p)
|
||||
(sclang-document-p (current-buffer)))
|
||||
(sclang-document-update-properties))
|
||||
(sclang-set-current-document (current-buffer)))
|
||||
|
||||
(defun sclang-document-change-major-mode-hook-function ()
|
||||
(sclang-close-document (current-buffer)))
|
||||
|
||||
;; =====================================================================
|
||||
;; command handlers
|
||||
;; =====================================================================
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentOpen
|
||||
(lambda (arg)
|
||||
(multiple-value-bind (file-name region-start region-length) arg
|
||||
(let ((buffer (get-file-buffer file-name)))
|
||||
(unless buffer
|
||||
(setf buffer (find-file-noselect file-name)))
|
||||
(when buffer
|
||||
(unless (sclang-document-p buffer)
|
||||
(with-current-buffer buffer (sclang-mode)))
|
||||
(goto-char (max (point-min) (min (point-max) region-start)))
|
||||
;; TODO: how to activate region in transient-mark-mode?
|
||||
(sclang-document-id buffer))))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentNew
|
||||
(lambda (arg)
|
||||
(multiple-value-bind (name str make-listener) arg
|
||||
(let ((buffer (generate-new-buffer name)))
|
||||
(with-current-buffer buffer
|
||||
(insert str)
|
||||
(set-buffer-modified-p nil)
|
||||
(sclang-mode))
|
||||
(sclang-document-id buffer)))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentClose
|
||||
(lambda (arg)
|
||||
(let ((doc (and (integerp arg) (sclang-get-document arg))))
|
||||
(and doc (kill-buffer doc)))
|
||||
nil))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentRename
|
||||
(lambda (arg)
|
||||
(multiple-value-bind (id name) arg
|
||||
(when (stringp name)
|
||||
(let ((doc (and (integerp id) (sclang-get-document id))))
|
||||
(when doc
|
||||
(with-current-buffer doc
|
||||
(rename-buffer name t)
|
||||
(sclang-document-update-property 'sclang-document-name))))))
|
||||
nil))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentSetEditable
|
||||
(lambda (arg)
|
||||
(multiple-value-bind (id flag) arg
|
||||
(let ((doc (and (integerp id) (sclang-get-document id))))
|
||||
(when doc
|
||||
(with-current-buffer doc
|
||||
(setq buffer-read-only (not flag))
|
||||
(sclang-document-update-property 'sclang-editable-p)))))
|
||||
nil))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentSwitchTo
|
||||
(lambda (arg)
|
||||
(let ((doc (and (integerp arg) (sclang-get-document arg))))
|
||||
(and doc (switch-to-buffer doc)))
|
||||
nil))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentPutString
|
||||
(lambda (arg)
|
||||
(multiple-value-bind (id str) arg
|
||||
(let ((doc (and (integerp id) (sclang-get-document id))))
|
||||
(when doc
|
||||
(with-current-buffer doc
|
||||
(insert str)
|
||||
)
|
||||
nil)))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_documentPopTo
|
||||
(lambda (arg)
|
||||
(let ((doc (and (integerp arg) (sclang-get-document arg))))
|
||||
(and doc (display-buffer doc)))
|
||||
nil))
|
||||
|
||||
;; =====================================================================
|
||||
;; sclang-mode
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-mode-set-local-variables ()
|
||||
(set (make-local-variable 'require-final-newline) nil)
|
||||
;; indentation
|
||||
(set (make-local-variable 'indent-line-function)
|
||||
'sclang-indent-line)
|
||||
(set (make-local-variable 'tab-width) 4)
|
||||
(set (make-local-variable 'indent-tabs-mode) t)
|
||||
;; comment formatting
|
||||
(set (make-local-variable 'comment-start) "// ")
|
||||
(set (make-local-variable 'comment-end) "")
|
||||
(set (make-local-variable 'comment-column) 40)
|
||||
(set (make-local-variable 'comment-start-skip) "/\\*+ *\\|//+ *")
|
||||
;; "\\(^\\|\\s-\\);?// *")
|
||||
(set (make-local-variable 'comment-multi-line) t)
|
||||
;; parsing and movement
|
||||
(set (make-local-variable 'parse-sexp-ignore-comments) t)
|
||||
(set (make-local-variable 'beginning-of-defun-function)
|
||||
'sclang-beginning-of-defun)
|
||||
(set (make-local-variable 'end-of-defun-function)
|
||||
'sclang-end-of-defun)
|
||||
;; paragraph formatting
|
||||
;; (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
|
||||
;; mostly copied from c++-mode, seems to work
|
||||
(set (make-local-variable 'paragraph-start)
|
||||
"[ \t]*\\(//+\\|\\**\\)[ \t]*$\\|^ ")
|
||||
(set (make-local-variable 'paragraph-separate) paragraph-start)
|
||||
(set (make-local-variable 'paragraph-ignore-fill-prefix) t)
|
||||
(set (make-local-variable 'adaptive-fill-mode) t)
|
||||
(set (make-local-variable 'adaptive-fill-regexp)
|
||||
"[ \t]*\\(//+\\|\\**\\)[ \t]*\\([ \t]*\\([-|#;>*]+[ \t]*\\|(?[0-9]+[.)][ \t]*\\)*\\)")
|
||||
;; font lock
|
||||
(set (make-local-variable 'font-lock-syntactic-face-function)
|
||||
'sclang-font-lock-syntactic-face)
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
sclang-font-lock-defaults)
|
||||
;; ---
|
||||
nil)
|
||||
|
||||
(defvar sclang-mode-map (sclang-fill-mode-map (make-sparse-keymap))
|
||||
"Keymap used in SuperCollider mode.")
|
||||
|
||||
(defvar sclang-mode-syntax-table (sclang-fill-syntax-table (make-syntax-table))
|
||||
"Syntax table used in SuperCollider mode.")
|
||||
|
||||
(defcustom sclang-mode-hook nil
|
||||
"*Hook run when entering SCLang mode."
|
||||
:group 'sclang-mode
|
||||
:type 'hook)
|
||||
|
||||
(defun sclang-mode ()
|
||||
"Major mode for editing SuperCollider language code.
|
||||
\\{sclang-mode-map}
|
||||
"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(set-syntax-table sclang-mode-syntax-table)
|
||||
(use-local-map sclang-mode-map)
|
||||
(setq mode-name "SCLang")
|
||||
(setq major-mode 'sclang-mode)
|
||||
(sclang-mode-set-local-variables)
|
||||
(sclang-set-font-lock-keywords)
|
||||
(sclang-init-document)
|
||||
(sclang-make-document)
|
||||
(run-hooks 'sclang-mode-hook))
|
||||
|
||||
;; =====================================================================
|
||||
;; module initialization
|
||||
;; =====================================================================
|
||||
|
||||
(add-to-list 'auto-mode-alist '("\\.\\(sc\\|scd\\)$" . sclang-mode))
|
||||
(add-to-list 'interpreter-mode-alist '("sclang" . sclang-mode))
|
||||
|
||||
(add-hook 'sclang-library-startup-hook 'sclang-document-library-startup-hook-function)
|
||||
(add-hook 'kill-buffer-hook 'sclang-document-kill-buffer-hook-function)
|
||||
(add-hook 'post-command-hook 'sclang-document-post-command-hook-function)
|
||||
(add-hook 'change-major-mode-hook 'sclang-document-change-major-mode-hook-function)
|
||||
|
||||
(provide 'sclang-mode)
|
||||
|
||||
;; EOF
|
||||
277
el/sclang-server.el
Normal file
277
el/sclang-server.el
Normal file
|
|
@ -0,0 +1,277 @@
|
|||
;; 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-and-compile
|
||||
(require 'cl))
|
||||
|
||||
(defcustom sclang-server-panel "Server.default.makeWindow"
|
||||
"*Expression to execute when `sclang-show-server-panel' is invoked."
|
||||
:group 'sclang-interface
|
||||
:type '(choice (const "Server.default.makeWindow")
|
||||
(const "\\SCUM.asClass.do { \\SCUM.asClass.desktop.showServerPanel }")
|
||||
string))
|
||||
|
||||
(defvar sclang-server-alist nil
|
||||
"Alist of currently defined synthesis servers.")
|
||||
|
||||
(defvar sclang-default-server nil
|
||||
"Default synthesis server.")
|
||||
|
||||
(defvar sclang-current-server nil
|
||||
"Currently selected synthesis server.")
|
||||
|
||||
(defvar sclang-current-server-initialized nil
|
||||
"Non nil when the current server has been initialized from the default server.")
|
||||
|
||||
(defconst sclang-server-running-face
|
||||
(let ((face (make-face 'sclang-server-running-face)))
|
||||
(set-face-foreground face "red")
|
||||
face)
|
||||
"Face for highlighting a server's running state in the mode-line.")
|
||||
|
||||
(defun sclang-get-server (&optional name)
|
||||
(unless name (setq name sclang-current-server))
|
||||
(cdr (assq name sclang-server-alist)))
|
||||
|
||||
(defun sclang-set-server (&optional name)
|
||||
(unless name (setq name sclang-current-server))
|
||||
(setq sclang-current-server
|
||||
(car (or (assq name sclang-server-alist)
|
||||
(car sclang-server-alist)))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_updateServer
|
||||
(lambda (arg)
|
||||
(setq sclang-server-alist
|
||||
(sort (cdr arg) (lambda (a b) (string< (car a) (car b)))))
|
||||
(setq sclang-default-server (car arg))
|
||||
(unless sclang-current-server-initialized
|
||||
;; only set the current server automatically once after startup
|
||||
(setq sclang-current-server-initialized t)
|
||||
(sclang-set-server sclang-default-server))
|
||||
(sclang-update-server-info)))
|
||||
|
||||
(defun sclang-next-server ()
|
||||
"Select next server for display."
|
||||
(interactive)
|
||||
(sclang-set-server)
|
||||
(let ((list (or (cdr (member-if (lambda (assoc)
|
||||
(eq (car assoc) sclang-current-server))
|
||||
sclang-server-alist))
|
||||
sclang-server-alist)))
|
||||
(setq sclang-current-server (car (car list))))
|
||||
(sclang-update-server-info))
|
||||
|
||||
(defun sclang-mouse-next-server (event)
|
||||
"Select next server for display."
|
||||
(interactive "e")
|
||||
(sclang-next-server))
|
||||
|
||||
(defun sclang-server-running-p (&optional name)
|
||||
(plist-get (sclang-get-server name) 'running))
|
||||
|
||||
(defun sclang-server-booting-p (&optional name)
|
||||
(plist-get (sclang-get-server name) 'booting))
|
||||
|
||||
(defun sclang-create-server-menu (title)
|
||||
(easy-menu-create-menu
|
||||
title
|
||||
'(
|
||||
["Boot" sclang-server-boot]
|
||||
["Quit" sclang-server-quit]
|
||||
"-"
|
||||
["Free All" sclang-server-free-all :active (sclang-server-running-p)]
|
||||
["Make Default" sclang-server-make-default]
|
||||
)))
|
||||
|
||||
(defun sclang-server-fill-mouse-map (map prefix)
|
||||
(define-key map (vector prefix 'mouse-1) 'sclang-mouse-next-server)
|
||||
(define-key map (vector prefix 'down-mouse-3) (sclang-create-server-menu "Commands"))
|
||||
map)
|
||||
|
||||
(defvar sclang-server-mouse-map (sclang-server-fill-mouse-map (make-sparse-keymap) 'mode-line)
|
||||
"Keymap used for controlling servers in the mode line.")
|
||||
|
||||
(defun sclang-server-fill-key-map (map)
|
||||
"Fill server prefix map."
|
||||
(define-key map [?b] 'sclang-server-boot)
|
||||
(define-key map [?d] 'sclang-server-display-default)
|
||||
(define-key map [?f] 'sclang-server-free-all)
|
||||
(define-key map [?m] 'sclang-server-make-default)
|
||||
(define-key map [?n] 'sclang-next-server)
|
||||
(define-key map [?o] 'sclang-server-dump-osc)
|
||||
(define-key map [?p] 'sclang-show-server-panel)
|
||||
(define-key map [?q] 'sclang-server-quit)
|
||||
(flet ((fill-record-map (map)
|
||||
(define-key map [?n] 'sclang-server-prepare-for-record)
|
||||
(define-key map [?p] 'sclang-server-pause-recording)
|
||||
(define-key map [?r] 'sclang-server-record)
|
||||
(define-key map [?s] 'sclang-server-stop-recording)
|
||||
map))
|
||||
(define-key map [?r] (fill-record-map (make-sparse-keymap))))
|
||||
map)
|
||||
|
||||
(defvar sclang-server-key-map (sclang-server-fill-key-map (make-sparse-keymap))
|
||||
"Keymap used for controlling servers.")
|
||||
|
||||
(defun sclang-get-server-info-string ()
|
||||
"Return a mode-line string for the current server."
|
||||
(let* ((name (if sclang-current-server (symbol-name sclang-current-server) "-------"))
|
||||
(server (sclang-get-server))
|
||||
(running-p (if server (plist-get server 'running)))
|
||||
(string (propertize
|
||||
name
|
||||
'face (if running-p sclang-server-running-face)
|
||||
'help-echo "mouse-1: next server, mouse-3: command menu"
|
||||
'keymap sclang-server-mouse-map))
|
||||
;; (make-mode-line-mouse-map 'mouse-1 'sclang-mouse-next-server)))
|
||||
(address (if (and server (not (eq (plist-get server 'type) 'internal)))
|
||||
(format " (%s)" (plist-get server 'address))
|
||||
""))
|
||||
(info (if running-p
|
||||
(mapcar 'number-to-string
|
||||
(plist-get (sclang-get-server) 'info))
|
||||
'("---" "---" "----" "----" "----" "----"))))
|
||||
(apply 'format "%s%s %3s|%3s %% u: %4s s: %4s g: %4s d: %4s" string address info)))
|
||||
|
||||
(defvar sclang-server-info-string (sclang-get-server-info-string)
|
||||
"Info string used in the post buffer mode line.")
|
||||
|
||||
(defun sclang-update-server-info ()
|
||||
(interactive)
|
||||
(sclang-set-server)
|
||||
(setq sclang-server-info-string (sclang-get-server-info-string))
|
||||
(force-mode-line-update))
|
||||
|
||||
;; =====================================================================
|
||||
;; language control
|
||||
;; =====================================================================
|
||||
|
||||
(defun sclang-perform-server-command (command &rest args)
|
||||
(sclang-eval-string
|
||||
(sclang-format "Server.named.at(%o.asSymbol).performList(\\tryPerform, %o.asSymbol.asArray ++ %o)"
|
||||
sclang-current-server command args)
|
||||
nil))
|
||||
|
||||
(defun sclang-server-boot ()
|
||||
"Boot the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "boot"))
|
||||
|
||||
(defun sclang-server-reboot ()
|
||||
"Reboot the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "reboot"))
|
||||
|
||||
(defun sclang-server-quit ()
|
||||
"Quit the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "quit"))
|
||||
|
||||
(defun sclang-server-free-all ()
|
||||
"Free all nodes on the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "freeAll"))
|
||||
|
||||
(defun sclang-server-display-default ()
|
||||
"Display default server."
|
||||
(interactive)
|
||||
(when sclang-default-server
|
||||
(sclang-set-server sclang-default-server)
|
||||
(sclang-update-server-info)))
|
||||
|
||||
(defun sclang-server-make-default ()
|
||||
"Make current server the default server."
|
||||
(interactive)
|
||||
(when sclang-current-server
|
||||
(sclang-eval-string
|
||||
(sclang-format "
|
||||
var server;
|
||||
server = Server.named.at(%o);
|
||||
if (server.notNil) {
|
||||
Server.default = server;
|
||||
thisProcess.interpreter.s = server;
|
||||
\"Default server: %\n\".postf(server.name);
|
||||
};
|
||||
" sclang-current-server))
|
||||
nil))
|
||||
|
||||
(defun sclang-server-dump-osc (&optional code)
|
||||
"Set the current server's dump OSC mode."
|
||||
(interactive "P")
|
||||
(sclang-perform-server-command "dumpOSC"
|
||||
(cond ((consp code) 0)
|
||||
((null code) 1)
|
||||
(t code))))
|
||||
|
||||
(defun sclang-server-prepare-for-record (&optional path)
|
||||
"Prepare current server for recording a sound file."
|
||||
(interactive
|
||||
(list
|
||||
(and current-prefix-arg (read-file-name "Record to file: "))))
|
||||
(sclang-perform-server-command "prepareForRecord" path))
|
||||
|
||||
(defun sclang-server-record ()
|
||||
"Record a sound file on the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "record"))
|
||||
|
||||
(defun sclang-server-pause-recording ()
|
||||
"Pause recording on the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "pauseRecording"))
|
||||
|
||||
(defun sclang-server-stop-recording ()
|
||||
"Stop recording on the current server."
|
||||
(interactive)
|
||||
(sclang-perform-server-command "stopRecording"))
|
||||
|
||||
(defun sclang-set-server-latency (lat)
|
||||
"Set the current server's `latency' instance variable."
|
||||
(interactive "nSet latency: ")
|
||||
(sclang-perform-server-command "latency_" lat))
|
||||
|
||||
(defun sclang-show-server-latency ()
|
||||
"Show the current server's latency."
|
||||
(interactive)
|
||||
(let ((server (sclang-get-server)))
|
||||
(message "%s" (and server (plist-get server 'latency)))))
|
||||
|
||||
(defun sclang-show-server-panel ()
|
||||
"Show graphical server panel if available."
|
||||
(interactive)
|
||||
(sclang-eval-string sclang-server-panel))
|
||||
|
||||
;; =====================================================================
|
||||
;; module setup
|
||||
;; =====================================================================
|
||||
|
||||
(add-hook 'sclang-mode-hook
|
||||
(lambda ()
|
||||
;; install server mode line in post buffer
|
||||
(when (string= (buffer-name) sclang-post-buffer)
|
||||
(setq mode-line-format '("-" sclang-server-info-string)))
|
||||
;; install server prefix keymap
|
||||
(define-key sclang-mode-map "\C-c\C-p" sclang-server-key-map)))
|
||||
|
||||
(add-hook 'sclang-library-shutdown-hook
|
||||
(lambda ()
|
||||
(setq sclang-current-server-initialized nil)))
|
||||
|
||||
(provide 'sclang-server)
|
||||
|
||||
;; EOF
|
||||
86
el/sclang-util.el
Normal file
86
el/sclang-util.el
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
;; 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
|
||||
|
||||
(defun sclang-message (string &rest args)
|
||||
(message "SCLang: %s" (apply 'format string args)))
|
||||
|
||||
(defun sclang-make-buffer-name (string &optional private-p)
|
||||
(concat (and private-p " ") "*SCLang:" string "*"))
|
||||
|
||||
(defun sclang-make-prompt-string (prompt default)
|
||||
(if (and default (string-match "\\(:\\)\\s *" prompt))
|
||||
(replace-match
|
||||
(format " (default %s):" default)
|
||||
'fixedcase 'literal prompt 1)
|
||||
prompt))
|
||||
|
||||
(defun sclang-string-to-int32 (str)
|
||||
"Convert first 4 bytes of str (network byteorder) to 32 bit integer."
|
||||
(logior (lsh (logand (aref str 0) #XFF) 24)
|
||||
(lsh (logand (aref str 1) #XFF) 16)
|
||||
(lsh (logand (aref str 2) #XFF) 8)
|
||||
(logand (aref str 3) #XFF)))
|
||||
|
||||
(defun sclang-int32-to-string (n)
|
||||
"Convert 32 bit integer n to 4 byte string (network byte order)."
|
||||
(let ((str (make-string 4 0)))
|
||||
(aset str 0 (logand (lsh n -24) #XFF))
|
||||
(aset str 1 (logand (lsh n -16) #XFF))
|
||||
(aset str 2 (logand (lsh n -8) #XFF))
|
||||
(aset str 3 (logand n #XFF))
|
||||
str))
|
||||
|
||||
(defun sclang-compress-newlines (&optional buffer)
|
||||
(with-current-buffer (or buffer (current-buffer))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(while (not (eobp))
|
||||
(if (and (bolp) (eolp)
|
||||
(save-excursion
|
||||
(forward-line -1)
|
||||
(and (bolp) (eolp))))
|
||||
(delete-char 1)
|
||||
(forward-line 1))))))
|
||||
|
||||
(eval-when-compile
|
||||
(defmacro sclang-save-buffer-state (varlist &rest body)
|
||||
"Bind variables according to VARLIST and eval BODY restoring buffer state."
|
||||
`(let* ,(append varlist
|
||||
'((modified (buffer-modified-p)) (buffer-undo-list t)
|
||||
(inhibit-read-only t) (inhibit-point-motion-hooks t)
|
||||
(inhibit-modification-hooks t)
|
||||
deactivate-mark buffer-file-name buffer-file-truename))
|
||||
(unwind-protect
|
||||
,@body
|
||||
(when (and (not modified) (buffer-modified-p))
|
||||
(set-buffer-modified-p nil))))))
|
||||
|
||||
;; (defun sclang-create-image (file-name &rest props)
|
||||
;; (when (file-exists-p file-name)
|
||||
;; (let ((coding-system-for-read 'no-conversion)
|
||||
;; (coding-system-for-write 'no-conversion)
|
||||
;; (inhibit-quit t))
|
||||
;; (with-temp-buffer
|
||||
;; (when (equal 0 (call-process "anytopnm" file-name (list (current-buffer) nil)))
|
||||
;; (apply
|
||||
;; 'create-image
|
||||
;; (buffer-substring-no-properties (point-min) (point-max))
|
||||
;; nil t props))))))
|
||||
|
||||
(provide 'sclang-util)
|
||||
|
||||
;; EOF
|
||||
34
el/sclang-vars.el.in
Normal file
34
el/sclang-vars.el.in
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
;;; sclang-vars.el --- Variables with build-time defaults
|
||||
|
||||
;; Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Mario Lang <mlang@delysid.org>
|
||||
|
||||
;; 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.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defconst sclang-system-data-dir "@PKG_DATA_DIR@"
|
||||
"Installation dependent data directory.")
|
||||
|
||||
(defconst sclang-system-help-dir "@PKG_DATA_DIR@/Help"
|
||||
"Installation dependent help directory.")
|
||||
|
||||
(defconst sclang-system-extension-dir "@PKG_DATA_DIR@/Extensions"
|
||||
"Installation dependent extension directory.")
|
||||
|
||||
(provide 'sclang-vars)
|
||||
;;; sclang-vars.el ends here
|
||||
162
el/sclang-widgets.el
Normal file
162
el/sclang-widgets.el
Normal file
|
|
@ -0,0 +1,162 @@
|
|||
;;; sclang-widgets.el --- Widget definitions for SCLang
|
||||
|
||||
;; Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: mlang <mlang@delysid.org>
|
||||
;; Keywords: comm
|
||||
|
||||
;; 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:
|
||||
|
||||
;;
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-and-compile (require 'sclang-interp))
|
||||
|
||||
(defvar sclang-widgets nil)
|
||||
(make-variable-buffer-local 'sclang-widgets)
|
||||
|
||||
;; Button (not used yet)
|
||||
|
||||
(define-widget 'sclang-button 'item
|
||||
"A button."
|
||||
:create #'sclang-widget-button-create
|
||||
:action #'sclang-widget-button-action)
|
||||
|
||||
(defun sclang-widget-button-create (widget)
|
||||
"Create WIDGET at point in the current buffer."
|
||||
(widget-specify-insert
|
||||
(let ((from (point))
|
||||
button-begin button-end)
|
||||
(setq button-begin (point))
|
||||
(insert (widget-get-indirect widget :button-prefix))
|
||||
|
||||
(princ (nth (widget-get widget :value) (widget-get widget :states)) (current-buffer))
|
||||
|
||||
(insert (widget-get-indirect widget :button-suffix))
|
||||
(setq button-end (point))
|
||||
|
||||
;; Specify button, and insert value.
|
||||
(and button-begin button-end
|
||||
(widget-specify-button widget button-begin button-end)))
|
||||
(let ((from (point-min-marker))
|
||||
(to (point-max-marker)))
|
||||
(set-marker-insertion-type from t)
|
||||
(set-marker-insertion-type to nil)
|
||||
(widget-put widget :from from)
|
||||
(widget-put widget :to to)))
|
||||
(widget-clear-undo))
|
||||
|
||||
(defun sclang-widget-button-action (widget event)
|
||||
(widget-value-set widget
|
||||
(if (>= (widget-get widget :value) (1- (length (widget-get widget :states))))
|
||||
0
|
||||
(1+ (widget-get widget :value))))
|
||||
(sclang-eval-string
|
||||
(sclang-format "EmacsWidget.idmap[%o].valueFromEmacs(%o)"
|
||||
(widget-get widget :id) (widget-get widget :value))))
|
||||
|
||||
(sclang-set-command-handler
|
||||
'_widgetSetStates
|
||||
(lambda (arg)
|
||||
(multiple-value-bind (buffer id states value) arg
|
||||
(with-current-buffer (get-buffer buffer)
|
||||
(let ((widget (cdr (find id sclang-widgets :key 'car))))
|
||||
(widget-put widget :states states)
|
||||
(widget-value-set widget value)
|
||||
value)))))
|
||||
|
||||
(define-widget 'sclang-slider 'default
|
||||
"Slider widget."
|
||||
:size 20
|
||||
:create #'sclang-widget-slider-create
|
||||
:button-prefix "["
|
||||
:button-suffix "]"
|
||||
:value 0.5
|
||||
:value-get #'widget-value-value-get
|
||||
:value-set #'sclang-widget-slider-value-set
|
||||
:action (lambda (widget event)
|
||||
(let ((pos (if event (posn-point (event-start event)) (point))))
|
||||
(widget-value-set widget (/ (float (- pos (widget-get widget :from))) (widget-get widget :size))))))
|
||||
|
||||
(defun sclang-widget-slider-create (widget)
|
||||
"Create WIDGET at point in the current buffer."
|
||||
(widget-specify-insert
|
||||
(let ((from (point))
|
||||
(inhibit-redisplay t)
|
||||
button-begin button-end)
|
||||
(setq button-begin (point))
|
||||
(insert (widget-get-indirect widget :button-prefix))
|
||||
|
||||
(insert-char ?- (widget-get widget :size))
|
||||
(backward-char (1+ (widget-put widget :current-pos (- (widget-get widget :size) (round (* (widget-get widget :value) (widget-get widget :size)))))))
|
||||
(delete-char 1) (insert "|")
|
||||
(goto-char (point-max))
|
||||
(insert (widget-get-indirect widget :button-suffix))
|
||||
(setq button-end (point))
|
||||
|
||||
;; Specify button
|
||||
(and button-begin button-end
|
||||
(widget-specify-button widget button-begin button-end)))
|
||||
(let ((from (point-min-marker))
|
||||
(to (point-max-marker)))
|
||||
(set-marker-insertion-type from t)
|
||||
(set-marker-insertion-type to nil)
|
||||
(widget-put widget :from from)
|
||||
(widget-put widget :to to)))
|
||||
(widget-clear-undo))
|
||||
|
||||
(defun sclang-widget-slider-value-set (widget value)
|
||||
(save-excursion
|
||||
(let ((inhibit-read-only t))
|
||||
(goto-char (widget-get widget :from))
|
||||
(forward-char (widget-get widget :current-pos))
|
||||
(insert "-") (delete-char 1)
|
||||
(widget-put widget :value value)
|
||||
(goto-char (widget-get widget :from))
|
||||
(let ((n (round (* value (widget-get widget :size)))))
|
||||
(widget-put widget :current-pos n)
|
||||
(forward-char n)
|
||||
(insert "|") (delete-char 1)))))
|
||||
|
||||
;; Class Tree
|
||||
|
||||
(require 'tree-widget)
|
||||
(define-widget 'sclang-class-tree 'tree-widget
|
||||
"Widget for displaying the SCLang Class Tree."
|
||||
:dynargs #'sclang-widget-class-tree-dynargs)
|
||||
|
||||
(defun sclang-widget-class-tree-dynargs (widget)
|
||||
(sclang-eval-sync (sclang-format "EmacsClassTree.dynargs(%o)"
|
||||
(widget-get widget :tag))))
|
||||
|
||||
(define-widget 'sclang-file-position 'item
|
||||
"File position link for the SCLang Class Tree widget."
|
||||
:format "%[%t%]\n"
|
||||
:action (lambda (widget event)
|
||||
(find-file-other-window (widget-get widget :filename))
|
||||
(goto-char (widget-get widget :char-pos))))
|
||||
|
||||
(defun sclang-class-tree (class-name)
|
||||
"Display a tree-view of the sub-classes and methods of CLASS-NAME."
|
||||
(interactive
|
||||
(list (sclang-read-symbol "Class: " "Object" #'sclang-class-name-p)))
|
||||
(sclang-eval-string (format "EmacsClassBrowser(%s)" class-name)))
|
||||
|
||||
(provide 'sclang-widgets)
|
||||
;;; sclang-widgets.el ends here
|
||||
71
el/sclang.el
Normal file
71
el/sclang.el
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
;;; sclang.el --- IDE for working with the SuperCollider language
|
||||
;; copyright 2003 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
|
||||
|
||||
;;; Code:
|
||||
(defgroup sclang nil
|
||||
"IDE for working with the SuperCollider language."
|
||||
:group 'languages)
|
||||
|
||||
(defgroup sclang-mode nil
|
||||
"Major mode for working with SuperCollider source code."
|
||||
:group 'sclang)
|
||||
|
||||
(defgroup sclang-minor-mode nil
|
||||
"Minor mode for working with SuperCollider source code."
|
||||
:group 'sclang)
|
||||
|
||||
(defgroup sclang-interface nil
|
||||
"Interface to the SuperCollider process."
|
||||
:group 'sclang)
|
||||
|
||||
(defgroup sclang-programs nil
|
||||
"Paths to programs used by sclang-mode."
|
||||
:group 'sclang-interface)
|
||||
|
||||
(defgroup sclang-options nil
|
||||
"Options for the SuperCollider process."
|
||||
:group 'sclang-interface)
|
||||
|
||||
(defun sclang-customize ()
|
||||
"Customize sclang variables."
|
||||
(interactive)
|
||||
(customize-group 'sclang))
|
||||
|
||||
(eval-and-compile
|
||||
(require 'cl))
|
||||
|
||||
(eval-and-compile
|
||||
(let ((load-path
|
||||
(if (and (boundp 'byte-compile-dest-file)
|
||||
(stringp byte-compile-dest-file))
|
||||
(cons (file-name-directory byte-compile-dest-file) load-path)
|
||||
load-path)))
|
||||
(require 'sclang-util)
|
||||
(require 'sclang-browser)
|
||||
(require 'sclang-interp)
|
||||
(require 'sclang-language)
|
||||
(require 'sclang-document)
|
||||
(require 'sclang-mode)
|
||||
(require 'sclang-minor-mode)
|
||||
(require 'sclang-help)
|
||||
(require 'sclang-server)
|
||||
(require 'sclang-widgets)))
|
||||
|
||||
(provide 'sclang)
|
||||
|
||||
;;; sclang.el ends here
|
||||
806
el/tree-widget.el
Normal file
806
el/tree-widget.el
Normal file
|
|
@ -0,0 +1,806 @@
|
|||
;;; tree-widget.el --- Tree widget
|
||||
|
||||
;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: David Ponce <david@dponce.com>
|
||||
;; Maintainer: David Ponce <david@dponce.com>
|
||||
;; Created: 16 Feb 2001
|
||||
;; Keywords: extensions
|
||||
|
||||
;; This file is part of GNU Emacs
|
||||
|
||||
;; 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, 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; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This library provide a tree widget useful to display data
|
||||
;; structures organized in a hierarchical order.
|
||||
;;
|
||||
;; The following properties are specific to the tree widget:
|
||||
;;
|
||||
;; :open
|
||||
;; Set to non-nil to expand the tree. By default the tree is
|
||||
;; collapsed.
|
||||
;;
|
||||
;; :node
|
||||
;; Specify the widget used to represent the value of a tree node.
|
||||
;; By default this is an `item' widget which displays the
|
||||
;; tree-widget :tag property value if defined, or a string
|
||||
;; representation of the tree-widget value.
|
||||
;;
|
||||
;; :keep
|
||||
;; Specify a list of properties to keep when the tree is collapsed
|
||||
;; so they can be recovered when the tree is expanded. This
|
||||
;; property can be used in child widgets too.
|
||||
;;
|
||||
;; :expander (obsoletes :dynargs)
|
||||
;; Specify a function to be called to dynamically provide the
|
||||
;; tree's children in response to an expand request. This function
|
||||
;; will be passed the tree widget and must return a list of child
|
||||
;; widgets.
|
||||
;;
|
||||
;; *Please note:* Child widgets returned by the :expander function
|
||||
;; are stored in the :args property of the tree widget. To speed
|
||||
;; up successive expand requests, the :expander function is not
|
||||
;; called again when the :args value is non-nil. To refresh child
|
||||
;; values, it is necessary to set the :args property to nil, then
|
||||
;; redraw the tree.
|
||||
;;
|
||||
;; :open-icon (default `tree-widget-open-icon')
|
||||
;; :close-icon (default `tree-widget-close-icon')
|
||||
;; :empty-icon (default `tree-widget-empty-icon')
|
||||
;; :leaf-icon (default `tree-widget-leaf-icon')
|
||||
;; Those properties define the icon widgets associated to tree
|
||||
;; nodes. Icon widgets must derive from the `tree-widget-icon'
|
||||
;; widget. The :tag and :glyph-name property values are
|
||||
;; respectively used when drawing the text and graphic
|
||||
;; representation of the tree. The :tag value must be a string
|
||||
;; that represent a node icon, like "[+]" for example. The
|
||||
;; :glyph-name value must the name of an image found in the current
|
||||
;; theme, like "close" for example (see also the variable
|
||||
;; `tree-widget-theme').
|
||||
;;
|
||||
;; :guide (default `tree-widget-guide')
|
||||
;; :end-guide (default `tree-widget-end-guide')
|
||||
;; :no-guide (default `tree-widget-no-guide')
|
||||
;; :handle (default `tree-widget-handle')
|
||||
;; :no-handle (default `tree-widget-no-handle')
|
||||
;; Those properties define `item'-like widgets used to draw the
|
||||
;; tree guide lines. The :tag property value is used when drawing
|
||||
;; the text representation of the tree. The graphic look and feel
|
||||
;; is given by the images named "guide", "no-guide", "end-guide",
|
||||
;; "handle", and "no-handle" found in the current theme (see also
|
||||
;; the variable `tree-widget-theme').
|
||||
;;
|
||||
;; These are the default :tag values for icons, and guide lines:
|
||||
;;
|
||||
;; open-icon "[-]"
|
||||
;; close-icon "[+]"
|
||||
;; empty-icon "[X]"
|
||||
;; leaf-icon ""
|
||||
;; guide " |"
|
||||
;; no-guide " "
|
||||
;; end-guide " `"
|
||||
;; handle "-"
|
||||
;; no-handle " "
|
||||
;;
|
||||
;; The text representation of a tree looks like this:
|
||||
;;
|
||||
;; [-] 1 (open-icon :node)
|
||||
;; |-[+] 1.0 (guide+handle+close-icon :node)
|
||||
;; |-[X] 1.1 (guide+handle+empty-icon :node)
|
||||
;; `-[-] 1.2 (end-guide+handle+open-icon :node)
|
||||
;; |- 1.2.1 (no-guide+no-handle+guide+handle+leaf-icon leaf)
|
||||
;; `- 1.2.2 (no-guide+no-handle+end-guide+handle+leaf-icon leaf)
|
||||
;;
|
||||
;; By default, images will be used instead of strings to draw a
|
||||
;; nice-looking tree. See the `tree-widget-image-enable',
|
||||
;; `tree-widget-themes-directory', and `tree-widget-theme' options for
|
||||
;; more details.
|
||||
|
||||
;;; History:
|
||||
;;
|
||||
|
||||
;;; Code:
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'wid-edit)
|
||||
|
||||
;;; Customization
|
||||
;;
|
||||
(defgroup tree-widget nil
|
||||
"Customization support for the Tree Widget library."
|
||||
:version "22.1"
|
||||
:group 'widgets)
|
||||
|
||||
(defcustom tree-widget-image-enable
|
||||
(not (or (featurep 'xemacs) (< emacs-major-version 21)))
|
||||
"*Non-nil means that tree-widget will try to use images."
|
||||
:type 'boolean
|
||||
:group 'tree-widget)
|
||||
|
||||
(defvar tree-widget-themes-load-path
|
||||
'(load-path
|
||||
(let ((dir (if (fboundp 'locate-data-directory)
|
||||
(locate-data-directory "tree-widget") ;; XEmacs
|
||||
data-directory)))
|
||||
(and dir (list dir (expand-file-name "images" dir))))
|
||||
)
|
||||
"List of locations where to search for the themes sub-directory.
|
||||
Each element is an expression that will be evaluated to return a
|
||||
single directory or a list of directories to search.
|
||||
|
||||
The default is to search in the `load-path' first, then in the
|
||||
\"images\" sub directory in the data directory, then in the data
|
||||
directory.
|
||||
The data directory is the value of the variable `data-directory' on
|
||||
Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
|
||||
XEmacs.")
|
||||
|
||||
(defcustom tree-widget-themes-directory "tree-widget"
|
||||
"*Name of the directory where to look up for image themes.
|
||||
When nil use the directory where the tree-widget library is located.
|
||||
When a relative name is specified, try to locate that sub directory in
|
||||
the locations specified in `tree-widget-themes-load-path'.
|
||||
The default is to use the \"tree-widget\" relative name."
|
||||
:type '(choice (const :tag "Default" "tree-widget")
|
||||
(const :tag "With the library" nil)
|
||||
(directory :format "%{%t%}:\n%v"))
|
||||
:group 'tree-widget)
|
||||
|
||||
(defcustom tree-widget-theme nil
|
||||
"*Name of the theme where to look up for images.
|
||||
It must be a sub directory of the directory specified in variable
|
||||
`tree-widget-themes-directory'. The default theme is \"default\".
|
||||
When an image is not found in a theme, it is searched in the default
|
||||
theme.
|
||||
|
||||
A complete theme must at least contain images with these file names
|
||||
with a supported extension (see also `tree-widget-image-formats'):
|
||||
|
||||
\"guide\"
|
||||
A vertical guide line.
|
||||
\"no-guide\"
|
||||
An invisible vertical guide line.
|
||||
\"end-guide\"
|
||||
End of a vertical guide line.
|
||||
\"handle\"
|
||||
Horizontal guide line that joins the vertical guide line to an icon.
|
||||
\"no-handle\"
|
||||
An invisible handle.
|
||||
|
||||
Plus images whose name is given by the :glyph-name property of the
|
||||
icon widgets used to draw the tree. By default these images are used:
|
||||
|
||||
\"open\"
|
||||
Icon associated to an expanded tree.
|
||||
\"close\"
|
||||
Icon associated to a collapsed tree.
|
||||
\"empty\"
|
||||
Icon associated to an expanded tree with no child.
|
||||
\"leaf\"
|
||||
Icon associated to a leaf node."
|
||||
:type '(choice (const :tag "Default" nil)
|
||||
(string :tag "Name"))
|
||||
:group 'tree-widget)
|
||||
|
||||
(defcustom tree-widget-image-properties-emacs
|
||||
'(:ascent center :mask (heuristic t))
|
||||
"*Default properties of Emacs images."
|
||||
:type 'plist
|
||||
:group 'tree-widget)
|
||||
|
||||
(defcustom tree-widget-image-properties-xemacs
|
||||
nil
|
||||
"*Default properties of XEmacs images."
|
||||
:type 'plist
|
||||
:group 'tree-widget)
|
||||
|
||||
(defcustom tree-widget-space-width 0.5
|
||||
"Amount of space between an icon image and a node widget.
|
||||
Must be a valid space :width display property."
|
||||
:group 'tree-widget
|
||||
:type 'sexp)
|
||||
|
||||
;;; Image support
|
||||
;;
|
||||
(eval-and-compile ;; Emacs/XEmacs compatibility stuff
|
||||
(cond
|
||||
;; XEmacs
|
||||
((featurep 'xemacs)
|
||||
(defsubst tree-widget-use-image-p ()
|
||||
"Return non-nil if image support is currently enabled."
|
||||
(and tree-widget-image-enable
|
||||
widget-glyph-enable
|
||||
(console-on-window-system-p)))
|
||||
(defsubst tree-widget-create-image (type file &optional props)
|
||||
"Create an image of type TYPE from FILE, and return it.
|
||||
Give the image the specified properties PROPS."
|
||||
(apply 'make-glyph `([,type :file ,file ,@props])))
|
||||
(defsubst tree-widget-image-formats ()
|
||||
"Return the alist of image formats/file name extensions.
|
||||
See also the option `widget-image-file-name-suffixes'."
|
||||
(delq nil
|
||||
(mapcar
|
||||
#'(lambda (fmt)
|
||||
(and (valid-image-instantiator-format-p (car fmt)) fmt))
|
||||
widget-image-file-name-suffixes)))
|
||||
)
|
||||
;; Emacs
|
||||
(t
|
||||
(defsubst tree-widget-use-image-p ()
|
||||
"Return non-nil if image support is currently enabled."
|
||||
(and tree-widget-image-enable
|
||||
widget-image-enable
|
||||
(display-images-p)))
|
||||
(defsubst tree-widget-create-image (type file &optional props)
|
||||
"Create an image of type TYPE from FILE, and return it.
|
||||
Give the image the specified properties PROPS."
|
||||
(apply 'create-image `(,file ,type nil ,@props)))
|
||||
(defsubst tree-widget-image-formats ()
|
||||
"Return the alist of image formats/file name extensions.
|
||||
See also the option `widget-image-conversion'."
|
||||
(delq nil
|
||||
(mapcar
|
||||
#'(lambda (fmt)
|
||||
(and (image-type-available-p (car fmt)) fmt))
|
||||
widget-image-conversion)))
|
||||
))
|
||||
)
|
||||
|
||||
;; Buffer local cache of theme data.
|
||||
(defvar tree-widget--theme nil)
|
||||
|
||||
(defsubst tree-widget-theme-name ()
|
||||
"Return the current theme name, or nil if no theme is active."
|
||||
(and tree-widget--theme (aref tree-widget--theme 0)))
|
||||
|
||||
(defsubst tree-widget-set-theme (&optional name)
|
||||
"In the current buffer, set the theme to use for images.
|
||||
The current buffer must be where the tree widget is drawn.
|
||||
Optional argument NAME is the name of the theme to use. It defaults
|
||||
to the value of the variable `tree-widget-theme'.
|
||||
Does nothing if NAME is already the current theme."
|
||||
(or name (setq name (or tree-widget-theme "default")))
|
||||
(unless (string-equal name (tree-widget-theme-name))
|
||||
(set (make-local-variable 'tree-widget--theme)
|
||||
(make-vector 4 nil))
|
||||
(aset tree-widget--theme 0 name)))
|
||||
|
||||
(defun tree-widget--locate-sub-directory (name path)
|
||||
"Locate the sub-directory NAME in PATH.
|
||||
Return the absolute name of the directory found, or nil if not found."
|
||||
(let (dir elt)
|
||||
(while (and (not dir) (consp path))
|
||||
(setq elt (condition-case nil (eval (car path)) (error nil))
|
||||
path (cdr path))
|
||||
(cond
|
||||
((stringp elt)
|
||||
(setq dir (expand-file-name name elt))
|
||||
(or (file-accessible-directory-p dir)
|
||||
(setq dir nil)))
|
||||
((and elt (not (equal elt (car path))))
|
||||
(setq dir (tree-widget--locate-sub-directory name elt)))))
|
||||
dir))
|
||||
|
||||
(defun tree-widget-themes-directory ()
|
||||
"Locate the directory where to search for a theme.
|
||||
It is defined in variable `tree-widget-themes-directory'.
|
||||
Return the absolute name of the directory found, or nil if the
|
||||
specified directory is not accessible."
|
||||
(let ((found (aref tree-widget--theme 1)))
|
||||
(cond
|
||||
;; The directory was not found.
|
||||
((eq found 'void)
|
||||
(setq found nil))
|
||||
;; The directory is available in the cache.
|
||||
(found)
|
||||
;; Use the directory where this library is located.
|
||||
((null tree-widget-themes-directory)
|
||||
(setq found (locate-library "tree-widget"))
|
||||
(when found
|
||||
(setq found (file-name-directory found))
|
||||
(or (file-accessible-directory-p found)
|
||||
(setq found nil))))
|
||||
;; Check accessibility of absolute directory name.
|
||||
((file-name-absolute-p tree-widget-themes-directory)
|
||||
(setq found (expand-file-name tree-widget-themes-directory))
|
||||
(or (file-accessible-directory-p found)
|
||||
(setq found nil)))
|
||||
;; Locate a sub-directory in `tree-widget-themes-load-path'.
|
||||
(t
|
||||
(setq found (tree-widget--locate-sub-directory
|
||||
tree-widget-themes-directory
|
||||
tree-widget-themes-load-path))))
|
||||
;; Store the result in the cache for later use.
|
||||
(aset tree-widget--theme 1 (or found 'void))
|
||||
found))
|
||||
|
||||
(defsubst tree-widget-set-image-properties (props)
|
||||
"In current theme, set images properties to PROPS."
|
||||
(aset tree-widget--theme 2 props))
|
||||
|
||||
(defun tree-widget-image-properties (file)
|
||||
"Return the properties of an image in current theme.
|
||||
FILE is the absolute file name of an image.
|
||||
|
||||
If there is a \"tree-widget-theme-setup\" library in the theme
|
||||
directory, where is located FILE, load it to setup theme images
|
||||
properties. Typically it should contain something like this:
|
||||
|
||||
(tree-widget-set-image-properties
|
||||
(if (featurep 'xemacs)
|
||||
'(:ascent center)
|
||||
'(:ascent center :mask (heuristic t))
|
||||
))
|
||||
|
||||
When there is no \"tree-widget-theme-setup\" library in the current
|
||||
theme directory, load the one from the default theme, if available.
|
||||
Default global properties are provided for respectively Emacs and
|
||||
XEmacs in the variables `tree-widget-image-properties-emacs', and
|
||||
`tree-widget-image-properties-xemacs'."
|
||||
;; If properties are in the cache, use them.
|
||||
(let ((plist (aref tree-widget--theme 2)))
|
||||
(unless plist
|
||||
;; Load tree-widget-theme-setup if available.
|
||||
(load (expand-file-name "tree-widget-theme-setup"
|
||||
(file-name-directory file)) t t)
|
||||
;; If properties have been setup, use them.
|
||||
(unless (setq plist (aref tree-widget--theme 2))
|
||||
;; Try from the default theme.
|
||||
(load (expand-file-name "../default/tree-widget-theme-setup"
|
||||
(file-name-directory file)) t t)
|
||||
;; If properties have been setup, use them.
|
||||
(unless (setq plist (aref tree-widget--theme 2))
|
||||
;; By default, use supplied global properties.
|
||||
(setq plist (if (featurep 'xemacs)
|
||||
tree-widget-image-properties-xemacs
|
||||
tree-widget-image-properties-emacs))
|
||||
;; Setup the cache.
|
||||
(tree-widget-set-image-properties plist))))
|
||||
plist))
|
||||
|
||||
(defconst tree-widget--cursors
|
||||
;; Pointer shapes when the mouse pointer is over inactive
|
||||
;; tree-widget images. This feature works since Emacs 22, and
|
||||
;; ignored on older versions, and XEmacs.
|
||||
'(
|
||||
("guide" . arrow)
|
||||
("no-guide" . arrow)
|
||||
("end-guide" . arrow)
|
||||
("handle" . arrow)
|
||||
("no-handle" . arrow)
|
||||
))
|
||||
|
||||
(defun tree-widget-lookup-image (name)
|
||||
"Look up in current theme for an image with NAME.
|
||||
Search first in current theme, then in default theme (see also the
|
||||
variable `tree-widget-theme').
|
||||
Return the first image found having a supported format, or nil if not
|
||||
found."
|
||||
(let ((default-directory (tree-widget-themes-directory)))
|
||||
(when default-directory
|
||||
(let (file (theme (tree-widget-theme-name)))
|
||||
(catch 'found
|
||||
(dolist (dir (if (string-equal theme "default")
|
||||
'("default") (list theme "default")))
|
||||
(dolist (fmt (tree-widget-image-formats))
|
||||
(dolist (ext (cdr fmt))
|
||||
(setq file (expand-file-name (concat name ext) dir))
|
||||
(and
|
||||
(file-readable-p file)
|
||||
(file-regular-p file)
|
||||
(throw
|
||||
'found
|
||||
(tree-widget-create-image
|
||||
(car fmt) file
|
||||
;; Add the pointer shape
|
||||
(cons :pointer
|
||||
(cons
|
||||
(or (cdr (assoc name tree-widget--cursors))
|
||||
'hand)
|
||||
(tree-widget-image-properties file)))))))))
|
||||
nil)))))
|
||||
|
||||
(defun tree-widget-find-image (name)
|
||||
"Find the image with NAME in current theme.
|
||||
NAME is an image file name sans extension.
|
||||
Return the image found, or nil if not found."
|
||||
(when (tree-widget-use-image-p)
|
||||
;; Ensure there is an active theme.
|
||||
(tree-widget-set-theme (tree-widget-theme-name))
|
||||
(let ((image (assoc name (aref tree-widget--theme 3))))
|
||||
;; The image NAME is found in the cache.
|
||||
(if image
|
||||
(cdr image)
|
||||
;; Search the image in current, and default themes.
|
||||
(prog1
|
||||
(setq image (tree-widget-lookup-image name))
|
||||
;; Store image reference in the cache for later use.
|
||||
(push (cons name image) (aref tree-widget--theme 3))))
|
||||
)))
|
||||
|
||||
;;; Widgets
|
||||
;;
|
||||
(defun tree-widget-button-click (event)
|
||||
"Move to the position clicked on, and if it is a button, invoke it.
|
||||
EVENT is the mouse event received."
|
||||
(interactive "e")
|
||||
(mouse-set-point event)
|
||||
(let ((pos (widget-event-point event)))
|
||||
(if (get-char-property pos 'button)
|
||||
(widget-button-click event))))
|
||||
|
||||
(defvar tree-widget-button-keymap
|
||||
(let ((km (make-sparse-keymap)))
|
||||
(if (boundp 'widget-button-keymap)
|
||||
;; XEmacs
|
||||
(progn
|
||||
(set-keymap-parent km widget-button-keymap)
|
||||
(define-key km [button1] 'tree-widget-button-click))
|
||||
;; Emacs
|
||||
(set-keymap-parent km widget-keymap)
|
||||
(define-key km [down-mouse-1] 'tree-widget-button-click))
|
||||
km)
|
||||
"Keymap used inside node buttons.
|
||||
Handle mouse button 1 click on buttons.")
|
||||
|
||||
(define-widget 'tree-widget-icon 'push-button
|
||||
"Basic widget other tree-widget icons are derived from."
|
||||
:format "%[%t%]"
|
||||
:button-keymap tree-widget-button-keymap ; XEmacs
|
||||
:keymap tree-widget-button-keymap ; Emacs
|
||||
:create 'tree-widget-icon-create
|
||||
:action 'tree-widget-icon-action
|
||||
:help-echo 'tree-widget-icon-help-echo
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-open-icon 'tree-widget-icon
|
||||
"Icon for an expanded tree-widget node."
|
||||
:tag "[-]"
|
||||
:glyph-name "open"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-empty-icon 'tree-widget-icon
|
||||
"Icon for an expanded tree-widget node with no child."
|
||||
:tag "[X]"
|
||||
:glyph-name "empty"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-close-icon 'tree-widget-icon
|
||||
"Icon for a collapsed tree-widget node."
|
||||
:tag "[+]"
|
||||
:glyph-name "close"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-leaf-icon 'tree-widget-icon
|
||||
"Icon for a tree-widget leaf node."
|
||||
:tag ""
|
||||
:glyph-name "leaf"
|
||||
:button-face 'default
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-guide 'item
|
||||
"Vertical guide line."
|
||||
:tag " |"
|
||||
;;:tag-glyph (tree-widget-find-image "guide")
|
||||
:format "%t"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-end-guide 'item
|
||||
"End of a vertical guide line."
|
||||
:tag " `"
|
||||
;;:tag-glyph (tree-widget-find-image "end-guide")
|
||||
:format "%t"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-no-guide 'item
|
||||
"Invisible vertical guide line."
|
||||
:tag " "
|
||||
;;:tag-glyph (tree-widget-find-image "no-guide")
|
||||
:format "%t"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-handle 'item
|
||||
"Horizontal guide line that joins a vertical guide line to a node."
|
||||
:tag "-"
|
||||
;;:tag-glyph (tree-widget-find-image "handle")
|
||||
:format "%t"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget-no-handle 'item
|
||||
"Invisible handle."
|
||||
:tag " "
|
||||
;;:tag-glyph (tree-widget-find-image "no-handle")
|
||||
:format "%t"
|
||||
)
|
||||
|
||||
(define-widget 'tree-widget 'default
|
||||
"Tree widget."
|
||||
:format "%v"
|
||||
:convert-widget 'widget-types-convert-widget
|
||||
:value-get 'widget-value-value-get
|
||||
:value-delete 'widget-children-value-delete
|
||||
:value-create 'tree-widget-value-create
|
||||
:action 'tree-widget-action
|
||||
:help-echo 'tree-widget-help-echo
|
||||
:open-icon 'tree-widget-open-icon
|
||||
:close-icon 'tree-widget-close-icon
|
||||
:empty-icon 'tree-widget-empty-icon
|
||||
:leaf-icon 'tree-widget-leaf-icon
|
||||
:guide 'tree-widget-guide
|
||||
:end-guide 'tree-widget-end-guide
|
||||
:no-guide 'tree-widget-no-guide
|
||||
:handle 'tree-widget-handle
|
||||
:no-handle 'tree-widget-no-handle
|
||||
)
|
||||
|
||||
;;; Widget support functions
|
||||
;;
|
||||
(defun tree-widget-p (widget)
|
||||
"Return non-nil if WIDGET is a tree-widget."
|
||||
(let ((type (widget-type widget)))
|
||||
(while (and type (not (eq type 'tree-widget)))
|
||||
(setq type (widget-type (get type 'widget-type))))
|
||||
(eq type 'tree-widget)))
|
||||
|
||||
(defun tree-widget-node (widget)
|
||||
"Return WIDGET's :node child widget.
|
||||
If not found, setup an `item' widget as default.
|
||||
Signal an error if the :node widget is a tree-widget.
|
||||
WIDGET is, or derives from, a tree-widget."
|
||||
(let ((node (widget-get widget :node)))
|
||||
(if node
|
||||
;; Check that the :node widget is not a tree-widget.
|
||||
(and (tree-widget-p node)
|
||||
(error "Invalid tree-widget :node %S" node))
|
||||
;; Setup an item widget as default :node.
|
||||
(setq node `(item :tag ,(or (widget-get widget :tag)
|
||||
(widget-princ-to-string
|
||||
(widget-value widget)))))
|
||||
(widget-put widget :node node))
|
||||
node))
|
||||
|
||||
(defun tree-widget-keep (arg widget)
|
||||
"Save in ARG the WIDGET's properties specified by :keep."
|
||||
(dolist (prop (widget-get widget :keep))
|
||||
(widget-put arg prop (widget-get widget prop))))
|
||||
|
||||
(defun tree-widget-children-value-save (widget &optional args node)
|
||||
"Save WIDGET children values.
|
||||
WIDGET is, or derives from, a tree-widget.
|
||||
Children properties and values are saved in ARGS if non-nil, else in
|
||||
WIDGET's :args property value. Properties and values of the
|
||||
WIDGET's :node sub-widget are saved in NODE if non-nil, else in
|
||||
WIDGET's :node sub-widget."
|
||||
(let ((args (cons (or node (widget-get widget :node))
|
||||
(or args (widget-get widget :args))))
|
||||
(children (widget-get widget :children))
|
||||
arg child)
|
||||
(while (and args children)
|
||||
(setq arg (car args)
|
||||
args (cdr args)
|
||||
child (car children)
|
||||
children (cdr children))
|
||||
(if (tree-widget-p child)
|
||||
;;;; The child is a tree node.
|
||||
(progn
|
||||
;; Backtrack :args and :node properties.
|
||||
(widget-put arg :args (widget-get child :args))
|
||||
(widget-put arg :node (widget-get child :node))
|
||||
;; Save :open property.
|
||||
(widget-put arg :open (widget-get child :open))
|
||||
;; The node is open.
|
||||
(when (widget-get child :open)
|
||||
;; Save the widget value.
|
||||
(widget-put arg :value (widget-value child))
|
||||
;; Save properties specified in :keep.
|
||||
(tree-widget-keep arg child)
|
||||
;; Save children.
|
||||
(tree-widget-children-value-save
|
||||
child (widget-get arg :args) (widget-get arg :node))))
|
||||
;;;; Another non tree node.
|
||||
;; Save the widget value.
|
||||
(widget-put arg :value (widget-value child))
|
||||
;; Save properties specified in :keep.
|
||||
(tree-widget-keep arg child)))))
|
||||
|
||||
;;; Widget creation
|
||||
;;
|
||||
(defvar tree-widget-before-create-icon-functions nil
|
||||
"Hooks run before to create a tree-widget icon.
|
||||
Each function is passed the icon widget not yet created.
|
||||
The value of the icon widget :node property is a tree :node widget or
|
||||
a leaf node widget, not yet created.
|
||||
This hook can be used to dynamically change properties of the icon and
|
||||
associated node widgets. For example, to dynamically change the look
|
||||
and feel of the tree-widget by changing the values of the :tag
|
||||
and :glyph-name properties of the icon widget.
|
||||
This hook should be local in the buffer setup to display widgets.")
|
||||
|
||||
(defun tree-widget-icon-create (icon)
|
||||
"Create the ICON widget."
|
||||
(run-hook-with-args 'tree-widget-before-create-icon-functions icon)
|
||||
(widget-put icon :tag-glyph
|
||||
(tree-widget-find-image (widget-get icon :glyph-name)))
|
||||
;; Ensure there is at least one char to display the image.
|
||||
(and (widget-get icon :tag-glyph)
|
||||
(equal "" (or (widget-get icon :tag) ""))
|
||||
(widget-put icon :tag " "))
|
||||
(widget-default-create icon)
|
||||
;; Insert space between the icon and the node widget.
|
||||
(insert-char ? 1)
|
||||
(put-text-property
|
||||
(1- (point)) (point)
|
||||
'display (list 'space :width tree-widget-space-width)))
|
||||
|
||||
(defun tree-widget-value-create (tree)
|
||||
"Create the TREE tree-widget."
|
||||
(let* ((node (tree-widget-node tree))
|
||||
(flags (widget-get tree :tree-widget--guide-flags))
|
||||
(indent (widget-get tree :indent))
|
||||
;; Setup widget's image support. Looking up for images, and
|
||||
;; setting widgets' :tag-glyph is done here, to allow to
|
||||
;; dynamically change the image theme.
|
||||
(widget-image-enable (tree-widget-use-image-p)) ; Emacs
|
||||
(widget-glyph-enable widget-image-enable) ; XEmacs
|
||||
children buttons)
|
||||
(and indent (not (widget-get tree :parent))
|
||||
(insert-char ?\ indent))
|
||||
(if (widget-get tree :open)
|
||||
;;;; Expanded node.
|
||||
(let ((args (widget-get tree :args))
|
||||
(xpandr (or (widget-get tree :expander)
|
||||
(widget-get tree :dynargs)))
|
||||
(guide (widget-get tree :guide))
|
||||
(noguide (widget-get tree :no-guide))
|
||||
(endguide (widget-get tree :end-guide))
|
||||
(handle (widget-get tree :handle))
|
||||
(nohandle (widget-get tree :no-handle))
|
||||
(guidi (tree-widget-find-image "guide"))
|
||||
(noguidi (tree-widget-find-image "no-guide"))
|
||||
(endguidi (tree-widget-find-image "end-guide"))
|
||||
(handli (tree-widget-find-image "handle"))
|
||||
(nohandli (tree-widget-find-image "no-handle")))
|
||||
;; Request children at run time, when not already done.
|
||||
(when (and (not args) xpandr)
|
||||
(setq args (mapcar 'widget-convert (funcall xpandr tree)))
|
||||
(widget-put tree :args args))
|
||||
;; Defer the node widget creation after icon creation.
|
||||
(widget-put tree :node (widget-convert node))
|
||||
;; Create the icon widget for the expanded tree.
|
||||
(push (widget-create-child-and-convert
|
||||
tree (widget-get tree (if args :open-icon :empty-icon))
|
||||
;; Pass the node widget to child.
|
||||
:node (widget-get tree :node))
|
||||
buttons)
|
||||
;; Create the tree node widget.
|
||||
(push (widget-create-child tree (widget-get tree :node))
|
||||
children)
|
||||
;; Update the icon :node with the created node widget.
|
||||
(widget-put (car buttons) :node (car children))
|
||||
;; Create the tree children.
|
||||
(while args
|
||||
(setq node (car args)
|
||||
args (cdr args))
|
||||
(and indent (insert-char ?\ indent))
|
||||
;; Insert guide lines elements from previous levels.
|
||||
(dolist (f (reverse flags))
|
||||
(widget-create-child-and-convert
|
||||
tree (if f guide noguide)
|
||||
:tag-glyph (if f guidi noguidi))
|
||||
(widget-create-child-and-convert
|
||||
tree nohandle :tag-glyph nohandli))
|
||||
;; Insert guide line element for this level.
|
||||
(widget-create-child-and-convert
|
||||
tree (if args guide endguide)
|
||||
:tag-glyph (if args guidi endguidi))
|
||||
;; Insert the node handle line
|
||||
(widget-create-child-and-convert
|
||||
tree handle :tag-glyph handli)
|
||||
(if (tree-widget-p node)
|
||||
;; Create a sub-tree node.
|
||||
(push (widget-create-child-and-convert
|
||||
tree node :tree-widget--guide-flags
|
||||
(cons (if args t) flags))
|
||||
children)
|
||||
;; Create the icon widget for a leaf node.
|
||||
(push (widget-create-child-and-convert
|
||||
tree (widget-get tree :leaf-icon)
|
||||
;; At this point the node widget isn't yet created.
|
||||
:node (setq node (widget-convert
|
||||
node :tree-widget--guide-flags
|
||||
(cons (if args t) flags)))
|
||||
:tree-widget--leaf-flag t)
|
||||
buttons)
|
||||
;; Create the leaf node widget.
|
||||
(push (widget-create-child tree node) children)
|
||||
;; Update the icon :node with the created node widget.
|
||||
(widget-put (car buttons) :node (car children)))))
|
||||
;;;; Collapsed node.
|
||||
;; Defer the node widget creation after icon creation.
|
||||
(widget-put tree :node (widget-convert node))
|
||||
;; Create the icon widget for the collapsed tree.
|
||||
(push (widget-create-child-and-convert
|
||||
tree (widget-get tree :close-icon)
|
||||
;; Pass the node widget to child.
|
||||
:node (widget-get tree :node))
|
||||
buttons)
|
||||
;; Create the tree node widget.
|
||||
(push (widget-create-child tree (widget-get tree :node))
|
||||
children)
|
||||
;; Update the icon :node with the created node widget.
|
||||
(widget-put (car buttons) :node (car children)))
|
||||
;; Save widget children and buttons. The tree-widget :node child
|
||||
;; is the first element in :children.
|
||||
(widget-put tree :children (nreverse children))
|
||||
(widget-put tree :buttons buttons)))
|
||||
|
||||
;;; Widget callbacks
|
||||
;;
|
||||
(defsubst tree-widget-leaf-node-icon-p (icon)
|
||||
"Return non-nil if ICON is a leaf node icon.
|
||||
That is, if its :node property value is a leaf node widget."
|
||||
(widget-get icon :tree-widget--leaf-flag))
|
||||
|
||||
(defun tree-widget-icon-action (icon &optional event)
|
||||
"Handle the ICON widget :action.
|
||||
If ICON :node is a leaf node it handles the :action. The tree-widget
|
||||
parent of ICON handles the :action otherwise.
|
||||
Pass the received EVENT to :action."
|
||||
(let ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
|
||||
:node :parent))))
|
||||
(widget-apply node :action event)))
|
||||
|
||||
(defun tree-widget-icon-help-echo (icon)
|
||||
"Return the help-echo string of ICON.
|
||||
If ICON :node is a leaf node it handles the :help-echo. The tree-widget
|
||||
parent of ICON handles the :help-echo otherwise."
|
||||
(let* ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
|
||||
:node :parent)))
|
||||
(help-echo (widget-get node :help-echo)))
|
||||
(if (functionp help-echo)
|
||||
(funcall help-echo node)
|
||||
help-echo)))
|
||||
|
||||
(defvar tree-widget-after-toggle-functions nil
|
||||
"Hooks run after toggling a tree-widget expansion.
|
||||
Each function is passed a tree-widget. If the value of the :open
|
||||
property is non-nil the tree has been expanded, else collapsed.
|
||||
This hook should be local in the buffer setup to display widgets.")
|
||||
|
||||
(defun tree-widget-action (tree &optional event)
|
||||
"Handle the :action of the TREE tree-widget.
|
||||
That is, toggle expansion of the TREE tree-widget.
|
||||
Ignore the EVENT argument."
|
||||
(let ((open (not (widget-get tree :open))))
|
||||
(or open
|
||||
;; Before to collapse the node, save children values so next
|
||||
;; open can recover them.
|
||||
(tree-widget-children-value-save tree))
|
||||
(widget-put tree :open open)
|
||||
(widget-value-set tree open)
|
||||
(run-hook-with-args 'tree-widget-after-toggle-functions tree)))
|
||||
|
||||
(defun tree-widget-help-echo (tree)
|
||||
"Return the help-echo string of the TREE tree-widget."
|
||||
(if (widget-get tree :open)
|
||||
"Collapse node"
|
||||
"Expand node"))
|
||||
|
||||
(provide 'tree-widget)
|
||||
|
||||
;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
|
||||
;;; tree-widget.el ends here
|
||||
320
sc/Emacs.sc
Normal file
320
sc/Emacs.sc
Normal file
|
|
@ -0,0 +1,320 @@
|
|||
// copyright 2003 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
|
||||
|
||||
EmacsInterface {
|
||||
classvar handlers;
|
||||
|
||||
*initClass {
|
||||
handlers = IdentityDictionary.new;
|
||||
this.initDefaultHandlers;
|
||||
}
|
||||
|
||||
*put { | name, function |
|
||||
handlers.put(name.asSymbol, function);
|
||||
}
|
||||
*at { | name |
|
||||
^handlers.at(name)
|
||||
}
|
||||
|
||||
*performCommand { | name, args |
|
||||
// [\performCommand, name, args].postln;
|
||||
^handlers.atFail(name, { ^nil }).valueArray(args)
|
||||
}
|
||||
|
||||
*makeSubListSorter { | index selector('<') |
|
||||
^{ | a b | a[index].perform(selector, b[index]) }
|
||||
}
|
||||
|
||||
*initDefaultHandlers {
|
||||
this
|
||||
.put(\symbolTable, { | fileName |
|
||||
var result, dt;
|
||||
|
||||
dt = {
|
||||
result = IdentitySet.new;
|
||||
|
||||
Class.allClasses.do { | class |
|
||||
if (class.isMetaClass.not) {
|
||||
result.add(class.name);
|
||||
};
|
||||
class.methods.do { | method |
|
||||
result.add(method.name);
|
||||
};
|
||||
};
|
||||
|
||||
File.use(fileName, "w", { | file |
|
||||
result.collectAs(_.asString, Array).storeLispOn(file);
|
||||
});
|
||||
}.bench(false);
|
||||
|
||||
"Emacs: Built symbol table in % seconds\n".postf(dt.asStringPrec(3));
|
||||
|
||||
true
|
||||
})
|
||||
.put(\openDefinition, { | name |
|
||||
var class, method, res;
|
||||
#class, method = name.split($-);
|
||||
class = class.asSymbol.asClass;
|
||||
if (class.notNil) {
|
||||
if (method.isNil) {
|
||||
res = [class.filenameSymbol.asString, class.charPos + 1];
|
||||
} {
|
||||
method = class.findMethod(method.asSymbol);
|
||||
if (method.notNil) {
|
||||
res = [method.filenameSymbol.asString, method.charPos + 1];
|
||||
};
|
||||
};
|
||||
};
|
||||
name -> res
|
||||
})
|
||||
.put(\classDefinitions, { | name |
|
||||
var result, class, files;
|
||||
|
||||
result = SortedList(8, this.makeSubListSorter(0, '<'));
|
||||
|
||||
if ((class = name.asSymbol.asClass).notNil) {
|
||||
files = IdentitySet.new;
|
||||
result.add([
|
||||
" " ++ name,
|
||||
class.filenameSymbol.asString,
|
||||
class.charPos + 1
|
||||
]);
|
||||
files.add(class.filenameSymbol);
|
||||
class.methods.do { | method |
|
||||
if (files.includes(method.filenameSymbol).not) {
|
||||
result = result.add([
|
||||
"+ " ++ name,
|
||||
method.filenameSymbol.asString,
|
||||
method.charPos + 1
|
||||
]);
|
||||
files.add(method.filenameSymbol);
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
name -> result
|
||||
})
|
||||
.put(\methodDefinitions, { | name |
|
||||
var result, symbol, getter, setter;
|
||||
|
||||
result = SortedList(8, this.makeSubListSorter(0, '<'));
|
||||
symbol = name.asSymbol;
|
||||
|
||||
Class.allClasses.do { | class |
|
||||
class.methods.do { | method |
|
||||
if (method.name === symbol) {
|
||||
result.add([
|
||||
class.name ++ "-" ++ name,
|
||||
method.filenameSymbol.asString,
|
||||
method.charPos + 1
|
||||
])
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
name -> result
|
||||
})
|
||||
.put(\methodReferences, { | name |
|
||||
var result, references, methods;
|
||||
|
||||
result = SortedList(8, this.makeSubListSorter(0, '<'));
|
||||
references = Class.findAllReferences(name.asSymbol);
|
||||
|
||||
if (references.notNil) {
|
||||
methods = IdentitySet.new;
|
||||
references.do { | funcDef |
|
||||
var homeContext;
|
||||
homeContext = funcDef.homeContext;
|
||||
if (homeContext.isKindOf(Method)) {
|
||||
methods.add(homeContext);
|
||||
};
|
||||
};
|
||||
methods.do { | method |
|
||||
result.add([
|
||||
method.ownerClass.name ++ "-" ++ method.name,
|
||||
method.filenameSymbol.asString,
|
||||
method.charPos + 1
|
||||
])
|
||||
}
|
||||
};
|
||||
|
||||
name -> result
|
||||
})
|
||||
.put(\methodArgs, { | className, methodName |
|
||||
var stream, class, method;
|
||||
var args, varArgs, lastIndex;
|
||||
|
||||
stream = CollStream.new;
|
||||
class = className.asSymbol.asClass;
|
||||
|
||||
if (class.notNil) {
|
||||
method = class.class.findRespondingMethodFor(methodName.asSymbol);
|
||||
if (method.notNil and: { method.argNames.notNil }) {
|
||||
args = method.argNames.copyToEnd(1);
|
||||
varArgs = method.varArgs;
|
||||
lastIndex = args.lastIndex;
|
||||
|
||||
args.do({ | name, i |
|
||||
var default;
|
||||
if (varArgs and: { i == lastIndex }) {
|
||||
stream << " ... ";
|
||||
}{
|
||||
if (i != 0) { stream << ", " };
|
||||
};
|
||||
stream << name;
|
||||
default = method.prototypeFrame[i+1];
|
||||
if (default.notNil) {
|
||||
stream << "=" << default;
|
||||
};
|
||||
});
|
||||
}
|
||||
};
|
||||
|
||||
stream.collection;
|
||||
})
|
||||
.put('evalSCLang', #{|expr, time|
|
||||
{[time, \ok, expr.interpret]}
|
||||
.try{|e|
|
||||
[time, \error, e.errorString]
|
||||
}
|
||||
})
|
||||
}
|
||||
}
|
||||
|
||||
Emacs {
|
||||
classvar outStream, outFile, requestHandlers, requestAllocator;
|
||||
classvar <menu, <>keys;
|
||||
classvar <initialized = false;
|
||||
|
||||
// initialization
|
||||
*initClass {
|
||||
var outFileName, newServer;
|
||||
Class.initClassTree(EmacsInterface);
|
||||
Class.initClassTree(EmacsDocument);
|
||||
Class.initClassTree(OSCresponder);
|
||||
Class.initClassTree(Server);
|
||||
requestHandlers = IdentityDictionary.new;
|
||||
requestAllocator = StackNumberAllocator(0, 128);
|
||||
keys = IdentityDictionary.new;
|
||||
outFileName = "SCLANG_COMMAND_FIFO".getenv;
|
||||
if (outFileName.isNil) {
|
||||
"Emacs: No communication FIFO available.".postln;
|
||||
}{
|
||||
initialized = true;
|
||||
Document.implementationClass = ScelDocument;
|
||||
thisProcess.platform.declareFeature( \emacs );
|
||||
outStream = CollStream.on(String.new);
|
||||
outFile = File(outFileName, "w");
|
||||
UI.registerForShutdown({
|
||||
if (outFile.notNil) {
|
||||
outFile.close;
|
||||
outFile = nil
|
||||
};
|
||||
});
|
||||
// initialize servers
|
||||
newServer = { | server update |
|
||||
SimpleController(server)
|
||||
.put(\serverRunning, { this.updateServer })
|
||||
.put(\counts, { this.updateServer });
|
||||
server.startAliveThread;
|
||||
if (update) { this.updateServer };
|
||||
};
|
||||
SimpleController(Server)
|
||||
.put(\serverAdded, { | serverClass what server | newServer.value(server, true) });
|
||||
Server.named.do(newServer.value(_, false));
|
||||
this.updateServer;
|
||||
// initialize lisp
|
||||
"Emacs: Initializing lisp interface.".postln;
|
||||
this.sendToLisp(\_init);
|
||||
};
|
||||
}
|
||||
|
||||
// lisp interface
|
||||
*lispPerformCommand { | cmdName, args, send |
|
||||
var result;
|
||||
result = EmacsInterface.performCommand(cmdName, args);
|
||||
if (send) {
|
||||
this.sendToLisp(cmdName, result);
|
||||
};
|
||||
^result
|
||||
}
|
||||
*lispHandleCommandResult { | id, obj |
|
||||
var handler;
|
||||
handler = requestHandlers.at(id);
|
||||
if (handler.notNil) {
|
||||
requestAllocator.free(id);
|
||||
handler.value(obj);
|
||||
}
|
||||
}
|
||||
|
||||
// sclang interface
|
||||
*sendToLisp { | cmd, obj, handler=nil |
|
||||
var id, str;
|
||||
if (outFile.notNil) {
|
||||
if (handler.notNil) {
|
||||
id = requestAllocator.alloc;
|
||||
if (id.notNil) {
|
||||
requestHandlers.put(id, handler);
|
||||
};
|
||||
};
|
||||
str = [cmd.asSymbol, obj, id].asLispString;
|
||||
outFile.putInt32(str.size);
|
||||
outFile.write(str);
|
||||
outFile.flush;
|
||||
}
|
||||
}
|
||||
*evalLispExpression { | expression, handler |
|
||||
this.sendToLisp('_eval', expression.asLispExpression, handler);
|
||||
}
|
||||
|
||||
// utilities
|
||||
*readFileName { | handler |
|
||||
this.evalLispExpression("(read-file-name \"Enter file name: \")", handler);
|
||||
}
|
||||
*message { | format ... args |
|
||||
this.evalLispExpression(([\message, format] ++ args).asLispString);
|
||||
}
|
||||
|
||||
*updateServer {
|
||||
var result;
|
||||
result = [Server.default.name];
|
||||
Server.named.do { arg server;
|
||||
result = result.add(
|
||||
server.name -> [
|
||||
'running', server.serverRunning,
|
||||
'type',
|
||||
if (server.inProcess) {\internal} {if (server.isLocal) {\local} {\remote}},
|
||||
'address', server.addr.ip,
|
||||
'client-id', server.clientID,
|
||||
'latency', server.latency,
|
||||
'notified', server.notified,
|
||||
'dump-mode', server.dumpMode,
|
||||
'info', [
|
||||
(server.avgCPU ? 0.0).round(0.1),
|
||||
(server.peakCPU ? 0.0).round(0.1),
|
||||
server.numUGens ? 0,
|
||||
server.numSynths ? 0,
|
||||
server.numGroups ? 0,
|
||||
server.numSynthDefs ? 0
|
||||
]
|
||||
]);
|
||||
};
|
||||
this.sendToLisp(\_updateServer, result)
|
||||
}
|
||||
}
|
||||
|
||||
// EOF
|
||||
324
sc/EmacsBuffer.sc
Normal file
324
sc/EmacsBuffer.sc
Normal file
|
|
@ -0,0 +1,324 @@
|
|||
// Emacs Widget library bindings for SCLang
|
||||
|
||||
EmacsBuffer { // Represents an Emacs buffer
|
||||
classvar all;
|
||||
var <name, <>onClose, <keymap;
|
||||
*initClass {
|
||||
Class.initClassTree(Emacs);
|
||||
all = Dictionary.new;
|
||||
Emacs.evalLispExpression(
|
||||
[\require, [\quote, 'wid-edit']].asLispString,
|
||||
{Emacs.evalLispExpression(
|
||||
[\defvar, 'sclang-widgets', \nil,
|
||||
"Maps IDs to Emacs widget objects."]
|
||||
.asLispString,
|
||||
{Emacs.evalLispExpression(
|
||||
['make-variable-buffer-local', [\quote, 'sclang-widgets']]
|
||||
.asLispString)})});
|
||||
}
|
||||
*new {|name="*SCWindow*"|
|
||||
^super.newCopyArgs(name).init;
|
||||
}
|
||||
init {
|
||||
all[name] = this;
|
||||
keymap = Dictionary.new;
|
||||
Emacs.evalLispExpression(
|
||||
['with-current-buffer', ['get-buffer-create', name],
|
||||
[\let, [['inhibit-read-only', \t]], ['erase-buffer']],
|
||||
['use-local-map',
|
||||
[\let, [[\map, ['make-sparse-keymap']]],
|
||||
['set-keymap-parent', \map, 'widget-keymap'],
|
||||
\map]],
|
||||
['add-hook', [\quote, 'kill-buffer-hook'],
|
||||
[\lambda, [],
|
||||
['sclang-eval-string',
|
||||
['sclang-format', "EmacsBuffer.killed(%o)",
|
||||
['buffer-name']]]],
|
||||
\nil, \t]].asLispString)
|
||||
}
|
||||
*at {|name| ^all[name] }
|
||||
defineKey {|keySeq,func|
|
||||
keymap.put(keySeq, func);
|
||||
Emacs.evalLispExpression(
|
||||
this.use(['local-set-key', keySeq,
|
||||
[\lambda, [],
|
||||
[\interactive],
|
||||
['sclang-eval-string',
|
||||
['sclang-format', "EmacsBuffer.at(%o).keymap.at(%o).value",
|
||||
['buffer-name'], keySeq]]]]).asLispString)
|
||||
}
|
||||
front { Emacs.evalLispExpression(['switch-to-buffer', name].asLispString) }
|
||||
use {|...args| ^['with-current-buffer', ['get-buffer', name]]++args }
|
||||
insert {|string|
|
||||
Emacs.evalLispExpression(
|
||||
this.use(['widget-insert', string]).asLispString
|
||||
)
|
||||
}
|
||||
goto {|position|
|
||||
Emacs.evalLispExpression(
|
||||
this.use(['goto-char', position]).asLispString
|
||||
)
|
||||
}
|
||||
gotoBob {
|
||||
Emacs.evalLispExpression(
|
||||
this.use(['goto-char', ['point-min']]).asLispString
|
||||
)
|
||||
}
|
||||
gotoEob {
|
||||
Emacs.evalLispExpression(
|
||||
this.use(['goto-char', ['point-max']]).asLispString
|
||||
)
|
||||
}
|
||||
newline { this.insert("\n") }
|
||||
editableField {|tag, value, action|
|
||||
EmacsEditableField(this, tag, value).action=action
|
||||
}
|
||||
button {|states, action, prefix="[", suffix="]"|
|
||||
EmacsButton(this, states, action, prefix, suffix)
|
||||
}
|
||||
closeButton {
|
||||
EmacsPushButton(this, "Close").action={this.free}
|
||||
}
|
||||
*killed {|name|
|
||||
var buf;
|
||||
buf = this.at(name);
|
||||
if (buf.isNil.not) {
|
||||
buf.onClose.value(buf);
|
||||
all.removeAt(name);
|
||||
}
|
||||
}
|
||||
free {
|
||||
onClose.value(this);
|
||||
all.removeAt(name);
|
||||
Emacs.evalLispExpression(['kill-buffer', name].asLispString,
|
||||
{super.free})
|
||||
}
|
||||
}
|
||||
|
||||
EmacsWidget {
|
||||
classvar allocator, <idmap;
|
||||
var <buffer, <type, <args, <id, <enabled;
|
||||
*initClass {
|
||||
allocator = StackNumberAllocator(0,1024);
|
||||
idmap = Array.newClear(1024);
|
||||
}
|
||||
*new {|buffer, type ... args|
|
||||
^super.newCopyArgs(buffer,type,args).init;
|
||||
}
|
||||
init {
|
||||
id = allocator.alloc;
|
||||
idmap[id] = this;
|
||||
enabled = true;
|
||||
Emacs.evalLispExpression(
|
||||
buffer.use(
|
||||
['add-to-list', [\quote, 'sclang-widgets'],
|
||||
[\cons, id, ['widget-create', [\quote, type], ':id', id]++args]],
|
||||
['widget-setup']).asLispString)
|
||||
}
|
||||
wPut {|argKey, argValue, handler|
|
||||
Emacs.evalLispExpression(
|
||||
buffer.use(['widget-put',
|
||||
[\cdr, [\find, id, 'sclang-widgets', ':key', [\quote, \car]]],
|
||||
(':'++argKey).asSymbol,
|
||||
[\quote, argValue]]).asLispString, handler)
|
||||
}
|
||||
wValueSet {|argValue, handler|
|
||||
Emacs.evalLispExpression(
|
||||
buffer.use(['widget-value-set',
|
||||
[\cdr, [\find, id, 'sclang-widgets', ':key', [\quote, \car]]],
|
||||
argValue]).asLispString, handler)
|
||||
}
|
||||
enabled_ {|argValue, handler|
|
||||
if (argValue) {
|
||||
Emacs.evalLispExpression(
|
||||
buffer.use(['widget-apply',
|
||||
[\cdr, [\find, id, 'sclang-widgets', ':key', [\quote, \car]]],
|
||||
':activate'], \nil).asLispString, {enabled=true;handler.value})
|
||||
} {
|
||||
Emacs.evalLispExpression(
|
||||
buffer.use(['widget-apply',
|
||||
[\cdr, [\find, id, 'sclang-widgets', ':key', [\quote, \car]]],
|
||||
':deactivate'], \nil).asLispString, {enabled=false;handler.value})
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
EmacsPushButton : EmacsWidget {
|
||||
var <>action;
|
||||
*new {|buffer, tag|
|
||||
^super.new(buffer, 'push-button', ':tag', tag, ':action',
|
||||
[\lambda, [\widget, \event],
|
||||
['sclang-eval-string',
|
||||
['sclang-format', "EmacsWidget.idmap[%o].action.value",
|
||||
['widget-get', \widget, ':id']]]])
|
||||
}
|
||||
}
|
||||
|
||||
EmacsEditableField : EmacsWidget {
|
||||
var <>action;
|
||||
*new {|buffer, tag, value=""|
|
||||
^super.new(buffer, 'editable-field', ':tag', tag,
|
||||
':format', "%{%t%}: %v",
|
||||
':action',
|
||||
[\lambda, [\widget, \event],
|
||||
['sclang-eval-string',
|
||||
['sclang-format', "EmacsWidget.idmap[%o].action.value(%o)",
|
||||
['widget-get', \widget, ':id'],
|
||||
['widget-value', \widget]]]],
|
||||
value)
|
||||
}
|
||||
}
|
||||
|
||||
EmacsNumber : EmacsWidget {
|
||||
var <>action, <>spec, <value;
|
||||
*new {|buffer, tag, spec, action, value=0|
|
||||
^super.new(buffer, \number, ':tag', tag,
|
||||
':format', "%{%t%}: %v",
|
||||
':min', spec.minval,
|
||||
':max', spec.maxval,
|
||||
':action',
|
||||
[\lambda, [\widget, \event],
|
||||
[\let, [[\val, ['widget-value', \widget]]],
|
||||
[\cond,
|
||||
[['>', \val, ['widget-get', \widget, ':max']],
|
||||
[\error, "Too much"]],
|
||||
[['<', \val, ['widget-get', \widget, ':min']],
|
||||
[\error, "Too less"]],
|
||||
[\t,
|
||||
['sclang-eval-string',
|
||||
['sclang-format', "EmacsWidget.idmap[%o].valueFromEmacs(%o)",
|
||||
['widget-get', \widget, ':id'], \val]]]]]],
|
||||
value).action_(action).spec_(spec).initValue(value)
|
||||
}
|
||||
valueFromEmacs {|argValue|
|
||||
value = argValue;
|
||||
action.value(value)
|
||||
}
|
||||
value_ {|argValue|
|
||||
Emacs.evalLispExpression(
|
||||
buffer.use(
|
||||
['save-excursion',
|
||||
['widget-value-set', [\cdr, [\find, id, 'sclang-widgets', ':key', [\quote, \car]]], argValue],
|
||||
['widget-setup']],
|
||||
argValue).asLispString,
|
||||
{|result|value=result})
|
||||
}
|
||||
initValue {|argValue|value=argValue}
|
||||
}
|
||||
|
||||
EmacsButton : EmacsWidget {
|
||||
var <>action, <value, <states;
|
||||
*new {|buffer, states=#[], action, prefix="[", suffix="]"|
|
||||
^super.new(buffer, 'sclang-button',
|
||||
':button-prefix', prefix,
|
||||
':button-suffix', suffix,
|
||||
':states', [\quote, states],
|
||||
0).action_(action).initValue(0).initStates(states)
|
||||
}
|
||||
valueFromEmacs {|argValue|
|
||||
value = argValue;
|
||||
action.value(value)
|
||||
}
|
||||
value_ {|argValue|
|
||||
this.wValueSet(argValue, {value = argValue});
|
||||
}
|
||||
states_ {|argStates|
|
||||
states=argStates;
|
||||
Emacs.sendToLisp(\_widgetSetStates, [buffer.name, id, states, value]);
|
||||
/* Emacs.evalLispExpression(
|
||||
buffer.use(
|
||||
[\let, [[\widget, [\cdr, [\find, id, 'sclang-widgets', ':key', [\quote, \car]]]],
|
||||
[\states, [\quote, states]]],
|
||||
['widget-put', \widget, ':states', \states],
|
||||
['widget-value-set', \widget, [\nth, value, \states]]]
|
||||
).asLispString) */
|
||||
}
|
||||
initStates {|argStates|states=argStates}
|
||||
initValue {|argValue|value=argValue}
|
||||
}
|
||||
|
||||
EmacsText : EmacsWidget {
|
||||
var <string, <size, <align;
|
||||
*new {|buffer, string="", size, align=\center|
|
||||
^super.new(buffer, \item, ':format', "%v", ':size', size?\nil, ':align', [\quote, align],
|
||||
':value-create',
|
||||
[\lambda, [\widget],
|
||||
['let*', [
|
||||
[\align, [\or, ['widget-get', \widget, ':align'], [\quote, \center]]],
|
||||
[\string, ['widget-get', \widget, ':value']],
|
||||
[\size, [\cond, [[\null, ['widget-get', \widget, ':size']], [\length, \string]],
|
||||
[['<', ['widget-get', \widget, ':size'], [\length, \string]], [\length, \string]],
|
||||
[\t, ['widget-get', \widget, ':size']]]]
|
||||
],
|
||||
[\insert,
|
||||
[\cond,
|
||||
[['=', \size, [\length, \string]], \string],
|
||||
[['>', \size, [\length, \string]],
|
||||
[\cond,
|
||||
[[\eq, \align, [\quote, \left]],
|
||||
[\concat, \string, ['make-string', ['-', \size, [\length, \string]], $ ]]],
|
||||
[[\eq, \align, [\quote, \right]],
|
||||
[\concat, ['make-string', ['-', \size, [\length, \string]], $ ], \string]],
|
||||
[[\eq, \align, [\quote, \center]],
|
||||
[\let, [[\half, ['/', ['-', \size, [\length, \string]], 2]]],
|
||||
[\if, ['=', ['+', [\length, \string], ['*', \half, 2]], \size],
|
||||
[\concat, ['make-string', \half, $ ], \string, ['make-string', \half, $ ]],
|
||||
[\concat, ['make-string', \half, $ ], \string, ['make-string', \half, $ ], " "]]]]]]]]]],
|
||||
string).initValue(size?string.size,align,string)
|
||||
}
|
||||
string_ {|argString|
|
||||
string = argString.asString;
|
||||
this.wValueSet(string);
|
||||
}
|
||||
size_ {|argSize|
|
||||
this.wPut(\size, size=argSize, {this.wValueSet(string)})
|
||||
}
|
||||
align_ {|argAlign|
|
||||
this.wPut(\align, align=argAlign, {this.wValueSet(string)})
|
||||
}
|
||||
initValue {|argSize,argAlign,argValue|size=argSize;align=argAlign;string=argValue}
|
||||
}
|
||||
|
||||
EmacsClassTree : EmacsWidget {
|
||||
*new {|buffer, className, open=true|
|
||||
^super.new(buffer, 'sclang-class-tree', ':tag', className.asString,
|
||||
':open', if(open){\t}{\nil},
|
||||
':node', [\quote, ['sclang-file-position',
|
||||
':filename', className.asSymbol.asClass.filenameSymbol.asString,
|
||||
':char-pos', className.asSymbol.asClass.charPos+1,
|
||||
':tag', className.asString]])
|
||||
}
|
||||
*dynargs {|className|
|
||||
var class;
|
||||
class = className.asSymbol.asClass;
|
||||
^(class.subclasses.asArray.copy.sort{|a,b|a.name <= b.name}.collect{|sc|
|
||||
['sclang-class-tree', ':tag', sc.name.asString,
|
||||
':node', ['sclang-file-position',
|
||||
':filename', sc.filenameSymbol.asString,
|
||||
':char-pos', sc.charPos+1,
|
||||
':tag', sc.name.asString]]})
|
||||
++
|
||||
(class.class.methods.asArray.copy.sort({|a,b| a.name <= b.name }).collect{|m|
|
||||
['sclang-file-position',
|
||||
':filename', m.filenameSymbol.asString,
|
||||
':char-pos', m.charPos+1,
|
||||
':tag', "*"++m.name.asString]})
|
||||
++
|
||||
(class.methods.asArray.copy.sort({|a,b| a.name <= b.name }).collect{|m|
|
||||
['sclang-file-position',
|
||||
':filename', m.filenameSymbol.asString,
|
||||
':char-pos', m.charPos+1,
|
||||
':tag', m.name.asString]})
|
||||
}
|
||||
}
|
||||
|
||||
EmacsClassBrowser {
|
||||
var w, classTree;
|
||||
*new {|class|
|
||||
^super.newCopyArgs(EmacsBuffer("*"++class.asClass.name++"*")).init(class);
|
||||
}
|
||||
init {|class|
|
||||
classTree=EmacsClassTree(w, class);
|
||||
w.gotoBob.front;
|
||||
}
|
||||
}
|
||||
307
sc/EmacsDocument.sc
Normal file
307
sc/EmacsDocument.sc
Normal file
|
|
@ -0,0 +1,307 @@
|
|||
// copyright 2003 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
|
||||
|
||||
EmacsDocument
|
||||
// : Document
|
||||
{
|
||||
classvar documentMap, <>current;
|
||||
var <>sceld;
|
||||
var title, path;
|
||||
var dataptr;
|
||||
var <isEdited, <isListener, <envir;
|
||||
|
||||
*initClass {
|
||||
documentMap = IdentityDictionary.new;
|
||||
Class.initClassTree(EmacsInterface);
|
||||
Class.initClassTree(ScelDocument);
|
||||
EmacsInterface
|
||||
.put(\documentNew, { | id, makeEnvir |
|
||||
var doc;
|
||||
if (documentMap.includesKey(id).not) {
|
||||
// [\documentNew, id, makeEnvir].postln;
|
||||
doc = this.prBasicNew.prInitFromLisp(id);
|
||||
// is this necessary?? when is this the case??
|
||||
if (makeEnvir.notNil) {
|
||||
doc.envir = Environment.new;
|
||||
};
|
||||
};
|
||||
nil
|
||||
})
|
||||
.put(\documentClosed, { | id |
|
||||
this.documentDo(id, { | doc |
|
||||
// [\documentClosed, doc].postln;
|
||||
doc.sceld.closed;
|
||||
});
|
||||
nil
|
||||
})
|
||||
.put(\documentSetCurrent, { | id |
|
||||
if (current.notNil) {
|
||||
// [\didResignKey, current].postln;
|
||||
current.didResignKey;
|
||||
};
|
||||
if (id.notNil) {
|
||||
this.documentDo(id, { | doc |
|
||||
// [\didBecomeKey, doc].postln;
|
||||
doc.didBecomeKey;
|
||||
});
|
||||
};
|
||||
nil
|
||||
})
|
||||
.put(\documentSetProperty, { | id, msg, value |
|
||||
this.documentDo(id, { | doc |
|
||||
// [\documentSetProperty, doc, msg, value].postln;
|
||||
doc.perform(msg, value);
|
||||
});
|
||||
nil
|
||||
});
|
||||
}
|
||||
|
||||
*documentDo { | id, function |
|
||||
var doc;
|
||||
doc = documentMap.at(id);
|
||||
^if (doc.notNil) {
|
||||
function.value(doc);
|
||||
}
|
||||
}
|
||||
*documentDoMsg { | id, selector ... args |
|
||||
var doc;
|
||||
doc = documentMap.at(id);
|
||||
^if (doc.notNil) {
|
||||
doc.performList(selector, args);
|
||||
}
|
||||
}
|
||||
|
||||
// lisp support
|
||||
storeLispOn { | stream |
|
||||
dataptr.storeLispOn(stream)
|
||||
}
|
||||
|
||||
// printing
|
||||
printOn { | stream |
|
||||
super.printOn(stream);
|
||||
stream << $( << this.title << $);
|
||||
}
|
||||
|
||||
//document setup
|
||||
title_ { | argName, completionFunc |
|
||||
Emacs.sendToLisp(\_documentRename, [this, argName], {
|
||||
completionFunc.value(this);
|
||||
});
|
||||
}
|
||||
|
||||
title{
|
||||
^title;
|
||||
}
|
||||
|
||||
background_ {arg color, rangestart= -1, rangesize = 0;
|
||||
}
|
||||
stringColor_ {arg color, rangeStart = -1, rangeSize = 0;
|
||||
}
|
||||
|
||||
//interaction:
|
||||
front {
|
||||
Emacs.sendToLisp(\_documentSwitchTo, this);
|
||||
}
|
||||
|
||||
unfocusedFront {
|
||||
Emacs.sendToLisp(\_documentPopTo, this);
|
||||
}
|
||||
|
||||
syntaxColorize {
|
||||
Emacs.sendToLisp(\_documentSyntaxColorize, this);
|
||||
}
|
||||
|
||||
selectRange { arg start=0, length=0;
|
||||
//_TextWindow_SelectRange
|
||||
}
|
||||
prisEditable_{ | flag = true |
|
||||
Emacs.sendToLisp(\_documentSetEditable, [this, flag]);
|
||||
}
|
||||
removeUndo{
|
||||
Emacs.sendToLisp(\_documentRemoveUndo, this);
|
||||
}
|
||||
|
||||
string{ arg rangestart, returnFunc, rangesize = 1;
|
||||
var rangeend, resultString;
|
||||
if ( rangestart.isNil,{
|
||||
rangestart = '(point-min)';
|
||||
rangeend = '(point-max)';
|
||||
},{
|
||||
rangeend = rangestart + rangesize;
|
||||
});
|
||||
Emacs.evalLispExpression(['with-current-buffer', title, [ 'buffer-substring-no-properties', rangestart, rangeend ]].asLispString;, { |result| returnFunc.value( result ); } );
|
||||
^nil;
|
||||
}
|
||||
|
||||
string_{|string|
|
||||
Emacs.sendToLisp(\_documentPutString, [this, string]);
|
||||
}
|
||||
|
||||
/* currentLine {
|
||||
^""
|
||||
}*/
|
||||
|
||||
// environment support
|
||||
/* envir_ { | environment |
|
||||
envir = environment;
|
||||
if (this === current) {
|
||||
envir.push;
|
||||
}
|
||||
}
|
||||
*/
|
||||
|
||||
didBecomeKey {
|
||||
if (envir.notNil) {
|
||||
envir.push;
|
||||
};
|
||||
current = this;
|
||||
}
|
||||
|
||||
didResignKey {
|
||||
if (envir === currentEnvironment) {
|
||||
envir.pop;
|
||||
};
|
||||
if ( current === this, { current = nil } );
|
||||
//super.didResignKey;
|
||||
}
|
||||
|
||||
|
||||
// PRIVATE
|
||||
*prNewFromPath { | argPath, selectionStart, selectionLength, completionFunc |
|
||||
argPath = Document.standardizePath(argPath);
|
||||
Emacs.sendToLisp(
|
||||
\_documentOpen,
|
||||
[argPath, selectionStart + 1, selectionLength],
|
||||
{ | id |
|
||||
if (id.isNil) {
|
||||
"Couldn't create document".warn;
|
||||
}{
|
||||
this.documentDo(id, completionFunc);
|
||||
}
|
||||
});
|
||||
}
|
||||
*prNewFromString { | name, str, makeListener, completionFunc |
|
||||
Emacs.sendToLisp(
|
||||
\_documentNew,
|
||||
[name, str, makeListener],
|
||||
{ | id |
|
||||
if (id.isNil) {
|
||||
"Couldn't create document".warn;
|
||||
}{
|
||||
this.documentDo(id, completionFunc);
|
||||
}
|
||||
});
|
||||
}
|
||||
prInitFromLisp { | id |
|
||||
dataptr = id;
|
||||
this.prAdd;
|
||||
}
|
||||
prclose {
|
||||
if (dataptr.notNil) {
|
||||
Emacs.sendToLisp(\_documentClose, this);
|
||||
}
|
||||
}
|
||||
prAdd {
|
||||
ScelDocument.addToList( this );
|
||||
// allDocuments = allDocuments.add(this);
|
||||
documentMap.put(dataptr, this);
|
||||
//initAction.value(this);
|
||||
}
|
||||
|
||||
prRemove {
|
||||
ScelDocument.removeFromList( this );
|
||||
// allDocuments.remove(this);
|
||||
documentMap.removeAt(dataptr);
|
||||
dataptr = nil;
|
||||
}
|
||||
|
||||
prGetTitle {
|
||||
^title
|
||||
}
|
||||
prSetTitle { | argTitle |
|
||||
title = argTitle;
|
||||
}
|
||||
|
||||
|
||||
prGetFileName {
|
||||
^path
|
||||
}
|
||||
prSetFileName { | argPath |
|
||||
path = argPath;
|
||||
if (path.notNil) {
|
||||
path = Document.standardizePath(path);
|
||||
}
|
||||
}
|
||||
|
||||
prSetIsListener { | flag |
|
||||
isListener = flag.notNil;
|
||||
}
|
||||
prSetEditable { | flag |
|
||||
// sceld.editable = flag.notNil;
|
||||
}
|
||||
prSetEdited { | flag |
|
||||
isEdited = flag.notNil;
|
||||
}
|
||||
|
||||
*prBasicNew { ^super.new }
|
||||
|
||||
// unimplemented methods
|
||||
/*
|
||||
prGetBounds { | bounds | ^bounds }
|
||||
prSetBounds { }
|
||||
setFont { }
|
||||
setTextColor { }
|
||||
text {
|
||||
^""
|
||||
}
|
||||
selectedText {
|
||||
^""
|
||||
}
|
||||
rangeText { arg rangestart=0, rangesize=1;
|
||||
^""
|
||||
}
|
||||
prinsertText { arg dataptr, txt;
|
||||
}
|
||||
insertTextRange { arg string, rangestart, rangesize;
|
||||
}
|
||||
setBackgroundColor { }
|
||||
selectedRangeLocation {
|
||||
^0
|
||||
}
|
||||
selectedRangeSize {
|
||||
^0
|
||||
}
|
||||
prselectLine { arg line;
|
||||
}
|
||||
|
||||
// invalid methods
|
||||
initByIndex {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
prinitByIndex {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
initLast {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
prGetLastIndex {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
*/
|
||||
}
|
||||
|
||||
// EOF
|
||||
317
sc/ScelDocument.sc
Normal file
317
sc/ScelDocument.sc
Normal file
|
|
@ -0,0 +1,317 @@
|
|||
// copyright 2007 Marije Baalman (nescivi AT gmail DOT com)
|
||||
//
|
||||
// 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
|
||||
|
||||
ScelDocument : Document{
|
||||
var <thisdoc;
|
||||
var cFuncs;
|
||||
var checkCurrent;
|
||||
var <envir;
|
||||
var title_p, path_p;
|
||||
var <>currentString;
|
||||
|
||||
*new{ | title = "Untitled", string = "", makeListener = false, toFront=true |
|
||||
// "ScelDocument.new".postln;
|
||||
^super.prBasicNew.init( title, string, makeListener, toFront );
|
||||
}
|
||||
|
||||
*open{ | path, selectionStart = 0, selectionLength = 0, toFront=true |
|
||||
^super.prBasicNew.initFromPath( path, selectionStart, selectionLength, toFront );
|
||||
}
|
||||
|
||||
*newFromEmacs{ |doc|
|
||||
^this.prBasicNew.prinitFromEmacs( doc );
|
||||
}
|
||||
|
||||
prinitFromEmacs{ |doc|
|
||||
thisdoc = doc;
|
||||
thisdoc.sceld = this;
|
||||
checkCurrent = { |doc| if ( EmacsDocument.current === doc, { this.didBecomeKey } ); };
|
||||
checkCurrent.value( doc );
|
||||
^this;
|
||||
}
|
||||
|
||||
initFromPath{ | path, selectionStart = 0, selectionLength = 0, toFront=true|
|
||||
checkCurrent = { |doc| if ( EmacsDocument.current === doc, { this.didBecomeKey } ); };
|
||||
cFuncs = [checkCurrent];
|
||||
path_p = path;
|
||||
title_p = path;
|
||||
EmacsDocument.prNewFromPath(path, selectionStart, selectionLength, { |doc| thisdoc = doc; thisdoc.sceld = this; cFuncs.do{ |it| it.value(doc); } } );
|
||||
if ( toFront, { this.front } );
|
||||
^this
|
||||
}
|
||||
|
||||
init{ |title, string, makeListener, toFront|
|
||||
// "ScelDocument.init".postln;
|
||||
checkCurrent = { |doc| if ( EmacsDocument.current === doc, { this.didBecomeKey } ); };
|
||||
cFuncs = [checkCurrent];
|
||||
title_p = title;
|
||||
EmacsDocument.prNewFromString(title, string, makeListener, { |doc| thisdoc = doc; thisdoc.sceld = this; cFuncs.do{ |it| it.value(doc)} });
|
||||
if ( toFront, { this.front } );
|
||||
^this
|
||||
}
|
||||
|
||||
string_ { | argName, completFunc |
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.string_( argName, completFunc )
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.string_( argName, completFunc ) };
|
||||
});
|
||||
}
|
||||
|
||||
title_ { | argName, completFunc |
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.title_( argName, completFunc )
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.title_( argName, completFunc ) };
|
||||
});
|
||||
}
|
||||
|
||||
title{
|
||||
if ( thisdoc.notNil, {
|
||||
^thisdoc.title;
|
||||
},{
|
||||
^("***"++title_p++"***")
|
||||
});
|
||||
}
|
||||
|
||||
// printing
|
||||
printOn { | stream |
|
||||
super.printOn(stream);
|
||||
stream << $( << this.title << $);
|
||||
}
|
||||
|
||||
prGetFileName {
|
||||
if ( thisdoc.notNil, {
|
||||
^thisdoc.path;
|
||||
},{
|
||||
^path_p;
|
||||
});
|
||||
}
|
||||
prSetFileName { | argPath |
|
||||
"sceldoc.prSetFileName".postln;
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.prSetFileName( argPath );
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.prSetFileName( argPath ) };
|
||||
});
|
||||
}
|
||||
|
||||
prSetFileName_ { | argPath |
|
||||
"sceldoc.prSetFileName_".postln;
|
||||
path_p = argPath;
|
||||
}
|
||||
|
||||
path_{ |path|
|
||||
"sceldoc.path".postln;
|
||||
this.prSetFileName( path );
|
||||
// if ( thisdoc.notNil, { thisdoc.path_( path ) },{ completionFuncs = completionFuncs ++ { this.path_( path ) }; });
|
||||
// ^this
|
||||
}
|
||||
|
||||
front {
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.front
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.front };
|
||||
});
|
||||
}
|
||||
|
||||
unfocusedFront {
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.unfocusedFront;
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.unfocusedFront };
|
||||
});
|
||||
}
|
||||
syntaxColorize {
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.syntaxColorize;
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.syntaxColorize };
|
||||
});
|
||||
}
|
||||
prisEditable_{ | flag = true |
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.prisEditable_( flag );
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.prisEditable_( flag ) };
|
||||
});
|
||||
editable = flag;
|
||||
}
|
||||
|
||||
removeUndo{
|
||||
if ( thisdoc.notNil, {
|
||||
thisdoc.removeUndo
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.removeUndo };
|
||||
});
|
||||
}
|
||||
|
||||
envir_ { | environment |
|
||||
envir = environment;
|
||||
if (this === current) {
|
||||
envir.push;
|
||||
}
|
||||
}
|
||||
|
||||
didBecomeKey {
|
||||
if (envir.notNil) {
|
||||
envir.push;
|
||||
};
|
||||
super.didBecomeKey;
|
||||
EmacsDocument.current = this;
|
||||
}
|
||||
|
||||
didResignKey {
|
||||
if (envir === currentEnvironment) {
|
||||
envir.pop;
|
||||
};
|
||||
super.didResignKey;
|
||||
}
|
||||
|
||||
// envir_ { | environment | thisdoc.envir_( environment ) }
|
||||
// didBecomeKey { thisdoc.didBecomeKey }
|
||||
// didResignKey { thisdoc.didResignKey }
|
||||
|
||||
closed {
|
||||
thisdoc.prRemove;
|
||||
onClose.value(this); // call user function
|
||||
// allDocuments.remove(this);
|
||||
// dataptr = nil;
|
||||
}
|
||||
|
||||
isEdited {
|
||||
if ( thisdoc.notNil, {
|
||||
^thisdoc.isEdited
|
||||
},{
|
||||
^false;
|
||||
});
|
||||
}
|
||||
// isFront { thisdoc.isFront }
|
||||
editable_{arg abool=true; this.prisEditable_( abool ) }
|
||||
|
||||
/* should maybe be this:
|
||||
path{
|
||||
if ( thisdoc.notNil, {
|
||||
^^thisdoc.prGetFileName;
|
||||
},{
|
||||
^path_p;
|
||||
});
|
||||
*/
|
||||
|
||||
path{^thisdoc.prGetFileName }
|
||||
|
||||
*addToList{ |doc|
|
||||
var key, sceld;
|
||||
// "adding to List".postln;
|
||||
key = allDocuments.detectIndex( { |it| it.thisdoc === doc } );
|
||||
if ( key.isNil,
|
||||
{
|
||||
sceld = ScelDocument.newFromEmacs( doc );
|
||||
allDocuments = allDocuments.add(sceld);
|
||||
initAction.value(sceld);
|
||||
});
|
||||
}
|
||||
*removeFromList{ |doc|
|
||||
var toremove;
|
||||
toremove = allDocuments.detectIndex( { |it| it.thisdoc === doc } );
|
||||
if ( toremove.notNil,
|
||||
{
|
||||
allDocuments.removeAt(toremove);
|
||||
});
|
||||
}
|
||||
|
||||
prclose {
|
||||
if ( thisdoc.notNil,{
|
||||
thisdoc.prclose
|
||||
},{
|
||||
cFuncs = cFuncs ++ { this.prclose };
|
||||
});
|
||||
}
|
||||
|
||||
string {arg rangestart, rangesize = 1;
|
||||
var cond;
|
||||
currentString = nil;
|
||||
thisdoc.string( rangestart, { |v| currentString = v }, rangesize );
|
||||
// cond = Condition.new( { currentString.notNil } );
|
||||
// cond.wait;
|
||||
// while ( { currentString.isNil }, {"wait for string".postln;} );
|
||||
^currentString;
|
||||
}
|
||||
text {
|
||||
^this.string;
|
||||
}
|
||||
rangeText { arg rangestart=0, rangesize=1;
|
||||
^this.string( rangestart, rangesize );
|
||||
}
|
||||
|
||||
// not implemented:
|
||||
selectRange { arg start=0, length=0; }
|
||||
background_ {arg color, rangestart= -1, rangesize = 0;
|
||||
}
|
||||
stringColor_ {arg color, rangeStart = -1, rangeSize = 0;
|
||||
}
|
||||
currentLine {
|
||||
^""
|
||||
}
|
||||
|
||||
prGetBounds { | bounds | ^bounds }
|
||||
prSetBounds { }
|
||||
setFont { }
|
||||
setTextColor { }
|
||||
selectedText {
|
||||
^""
|
||||
}
|
||||
prinsertText { arg dataptr, txt;
|
||||
}
|
||||
insertTextRange { arg string, rangestart, rangesize;
|
||||
}
|
||||
setBackgroundColor { }
|
||||
selectedRangeLocation {
|
||||
^0
|
||||
}
|
||||
selectedRangeSize {
|
||||
^0
|
||||
}
|
||||
prselectLine { arg line;
|
||||
}
|
||||
|
||||
bounds_{
|
||||
}
|
||||
|
||||
*current {
|
||||
^EmacsDocument.current.sceld;
|
||||
}
|
||||
|
||||
*prGetIndexOfListener{
|
||||
^this.allDocuments.detectIndex( { |doc| doc.title == "*SCLang:PostBuffer*" } );
|
||||
}
|
||||
|
||||
// invalid methods
|
||||
initByIndex {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
prinitByIndex {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
initLast {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
prGetLastIndex {
|
||||
^this.shouldNotImplement(thisMethod)
|
||||
}
|
||||
}
|
||||
237
sc/extBuffer.sc
Normal file
237
sc/extBuffer.sc
Normal file
|
|
@ -0,0 +1,237 @@
|
|||
+ Server {
|
||||
|
||||
makeWindow { arg w;
|
||||
this.makeEmacsWindow( w );
|
||||
}
|
||||
|
||||
makeEmacsWindow { arg w;
|
||||
var active, booter, killer, makeDefault, running, booting, stopped;
|
||||
var recorder, scoper;
|
||||
var countsViews, ctlr;
|
||||
var dumping=false, startDump, stopDump, stillRunning;
|
||||
|
||||
if (emacsbuf.notNil, { ^emacsbuf.front });
|
||||
|
||||
if(w.isNil,{
|
||||
w = emacsbuf = EmacsBuffer("*" ++ name.asString ++ " server*");
|
||||
});
|
||||
|
||||
if(isLocal,{
|
||||
booter = EmacsButton(w, ["Boot","Quit"]);
|
||||
booter.action = { arg value;
|
||||
if(value == 1, {
|
||||
booting.value;
|
||||
this.boot;
|
||||
});
|
||||
if(value == 0,{
|
||||
this.quit;
|
||||
});
|
||||
};
|
||||
booter.value=serverRunning.binaryValue;
|
||||
|
||||
killer = EmacsButton(w, ["K"], { Server.killAll });
|
||||
killer.enabled = false;
|
||||
});
|
||||
|
||||
active = EmacsText(w, this.name.asString, 12, \center);
|
||||
// active.background = Color.black;
|
||||
if(serverRunning,running,stopped);
|
||||
|
||||
makeDefault = EmacsButton(w, ["-> default"], {
|
||||
thisProcess.interpreter.s = this;
|
||||
Server.default = this;
|
||||
});
|
||||
|
||||
w.newline;
|
||||
|
||||
recorder = EmacsButton(w, ["prepare rec","record >","stop []"], {
|
||||
if (recorder.value == 1) {
|
||||
this.prepareForRecord;
|
||||
}{
|
||||
if (recorder.value == 2) { this.record } { this.stopRecording };
|
||||
};
|
||||
});
|
||||
|
||||
recorder.enabled = false;
|
||||
|
||||
stillRunning = {
|
||||
SystemClock.sched(0.2, { this.stopAliveThread });
|
||||
};
|
||||
w.defineKey("n", { this.queryAllNodes })
|
||||
.defineKey(" ", { if(serverRunning.not) { this.boot } })
|
||||
.defineKey("d", {
|
||||
startDump = {
|
||||
this.dumpOSC(1);
|
||||
this.stopAliveThread;
|
||||
dumping = true;
|
||||
CmdPeriod.add(stillRunning);
|
||||
};
|
||||
stopDump = {
|
||||
this.dumpOSC(0);
|
||||
this.startAliveThread;
|
||||
dumping = false;
|
||||
CmdPeriod.remove(stillRunning);
|
||||
};
|
||||
if(dumping, stopDump, startDump)
|
||||
});
|
||||
|
||||
if (isLocal, {
|
||||
running = {
|
||||
// active.stringColor_(Color.red);
|
||||
booter.value=1;
|
||||
recorder.enabled = true;
|
||||
killer.enabled = true;
|
||||
};
|
||||
stopped = {
|
||||
// active.stringColor_(Color.grey(0.3));
|
||||
booter.value=0;
|
||||
recorder.value=0;
|
||||
recorder.enabled = false;
|
||||
killer.enabled = false;
|
||||
};
|
||||
booting = {
|
||||
// active.stringColor_(Color.yellow(0.9));
|
||||
//booter.setProperty(\value,0);
|
||||
};
|
||||
|
||||
w.onClose = {
|
||||
emacsbuf = nil;
|
||||
ctlr.remove;
|
||||
};
|
||||
},{
|
||||
running = {
|
||||
// active.background = Color.red;
|
||||
recorder.enabled = true;
|
||||
};
|
||||
stopped = {
|
||||
// active.background = Color.black;
|
||||
recorder.value=0;
|
||||
recorder.enabled = false;
|
||||
};
|
||||
booting = {
|
||||
// active.background = Color.yellow;
|
||||
};
|
||||
w.onClose = {
|
||||
this.stopAliveThread;
|
||||
ctlr.remove;
|
||||
};
|
||||
});
|
||||
if(serverRunning,running,stopped);
|
||||
|
||||
w.newline;
|
||||
|
||||
countsViews =
|
||||
#[
|
||||
"Avg CPU: ", "Peak CPU: ",
|
||||
"UGens: ", "Synths: ", "Groups: ", "SynthDefs: "
|
||||
].collect({ arg name, i;
|
||||
var label,numView, pctView;
|
||||
label = EmacsText(w, name, 12, \right);
|
||||
|
||||
if (i < 2, {
|
||||
numView = EmacsText(w, "?", 5, \right);
|
||||
pctView = EmacsText(w, "%");
|
||||
},{
|
||||
numView = EmacsText(w, "?", 6, \left);
|
||||
});
|
||||
if (i == 1) { w.newline };
|
||||
numView
|
||||
});
|
||||
|
||||
ctlr = SimpleController(this)
|
||||
.put(\serverRunning, { if(serverRunning,running,stopped) })
|
||||
.put(\counts,{
|
||||
countsViews.at(0).string = avgCPU.round(0.1);
|
||||
countsViews.at(1).string = peakCPU.round(0.1);
|
||||
countsViews.at(2).string = numUGens;
|
||||
countsViews.at(3).string = numSynths;
|
||||
countsViews.at(4).string = numGroups;
|
||||
countsViews.at(5).string = numSynthDefs;
|
||||
})
|
||||
.put(\cmdPeriod,{
|
||||
recorder.value=0;
|
||||
});
|
||||
w.gotoBob;
|
||||
w.front;
|
||||
this.startAliveThread;
|
||||
}
|
||||
}
|
||||
|
||||
+ SynthDesc {
|
||||
makeWindow {
|
||||
var w, s, startButton, sliders;
|
||||
var id, cmdPeriodFunc;
|
||||
var synthDesc;
|
||||
var usefulControls, numControls;
|
||||
var getSliderValues;
|
||||
|
||||
s = Server.default;
|
||||
|
||||
usefulControls = controls.select {|controlName, i|
|
||||
var ctlname;
|
||||
ctlname = controlName.name;
|
||||
(ctlname != "?") && (ctlname != "gate")
|
||||
};
|
||||
|
||||
numControls = usefulControls.size;
|
||||
sliders = Array.newClear(numControls);
|
||||
|
||||
id = s.nextNodeID; // generate a note id.
|
||||
|
||||
// make the window
|
||||
w = EmacsBuffer("*SynthDesc"+name++"*");
|
||||
// add a button to start and stop the sound.
|
||||
startButton = EmacsButton(w, ["Start","Stop"]);
|
||||
w.newline;
|
||||
getSliderValues = {
|
||||
var envir;
|
||||
|
||||
envir = ();
|
||||
usefulControls.do {|controlName, i|
|
||||
var ctlname;
|
||||
ctlname = controlName.name.asSymbol;
|
||||
envir.put(ctlname, sliders[i].value);
|
||||
};
|
||||
envir.use {
|
||||
msgFunc.valueEnvir
|
||||
};
|
||||
};
|
||||
|
||||
startButton.action = {|value|
|
||||
if (value == 1) {
|
||||
// start sound
|
||||
s.sendBundle(s.latency, ["/s_new", name, id, 0, 0] ++ getSliderValues.value);
|
||||
};
|
||||
if (value == 0) {
|
||||
if (hasGate) {
|
||||
// set gate to zero to cause envelope to release
|
||||
s.sendMsg("/n_set", id, "gate", 0);
|
||||
}{
|
||||
s.sendMsg("/n_free", id);
|
||||
};
|
||||
};
|
||||
};
|
||||
|
||||
// create controls for all parameters
|
||||
usefulControls.do {|controlName, i|
|
||||
var ctlname, ctlname2, capname, spec;
|
||||
ctlname = controlName.name;
|
||||
capname = ctlname.copy;
|
||||
capname[0] = capname[0].toUpper;
|
||||
spec = ctlname.asSymbol.asSpec;
|
||||
sliders[i] = EmacsNumber(w, capname, spec?ControlSpec(-1e8,1e8),
|
||||
{|ez| s.sendMsg("/n_set", id, ctlname, ez); }, controlName.defaultValue);
|
||||
};
|
||||
|
||||
// set start button to zero upon a cmd-period
|
||||
cmdPeriodFunc = { startButton.value = 0; };
|
||||
CmdPeriod.add(cmdPeriodFunc);
|
||||
|
||||
// stop the sound when window closes and remove cmdPeriodFunc.
|
||||
w.onClose = {
|
||||
s.sendMsg("/n_free", id);
|
||||
CmdPeriod.remove(cmdPeriodFunc);
|
||||
};
|
||||
w.front; // make window visible and front window.
|
||||
}
|
||||
}
|
||||
5
sc/extClassBrowser.sc
Normal file
5
sc/extClassBrowser.sc
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
+ ClassBrowser{
|
||||
openSVN{ |svnAddr|
|
||||
Emacs.evalLispExpression(['w3m-browse-url', svnAddr].asLispString);
|
||||
}
|
||||
}
|
||||
73
sc/extDocument.sc
Normal file
73
sc/extDocument.sc
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
// copyright 2003 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
|
||||
|
||||
|
||||
+ Document {
|
||||
// Document class for Emacs interface.
|
||||
//
|
||||
// Delegates to ScelDocument, which delegates to EmacsDocument.
|
||||
|
||||
// moved to Emacs, upon startup
|
||||
// *implementationClass { ^ScelDocument }
|
||||
|
||||
// PRIVATE
|
||||
// *newFromIndex { ^this.shouldNotImplement(thisMethod) }
|
||||
*prGetLast { ^allDocuments.last }
|
||||
}
|
||||
|
||||
|
||||
+ String{
|
||||
findHelpFile {
|
||||
if ( Emacs.initialized) {
|
||||
Emacs.evalLispExpression(['sclang-find-help', this].asLispString);
|
||||
}
|
||||
}
|
||||
|
||||
openHelpFile {
|
||||
if ( Emacs.initialized) {
|
||||
this.findHelpFile;
|
||||
}
|
||||
}
|
||||
|
||||
openHTMLFile {
|
||||
if ( Emacs.initialized) {
|
||||
// this.findHelpFile;
|
||||
Emacs.evalLispExpression(['w3m-browse-url', this].asLispString);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
+ Class{
|
||||
openHelpFile {
|
||||
if ( Emacs.initialized) {
|
||||
this.asString.findHelpFile;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
+ Method{
|
||||
|
||||
openHelpFile {
|
||||
if ( Emacs.initialized) {
|
||||
this.asString.findHelpFile;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
// EOF
|
||||
5
sc/homeContext.sc
Normal file
5
sc/homeContext.sc
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
+ FunctionDef {
|
||||
homeContext {
|
||||
^if (context.isNil) { this } { context.homeContext }
|
||||
}
|
||||
}
|
||||
117
sc/storeLispOn.sc
Normal file
117
sc/storeLispOn.sc
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
// copyright 2003 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
|
||||
|
||||
+ Object {
|
||||
asLispString {
|
||||
var stream;
|
||||
stream = CollStream.new;
|
||||
this.storeLispOn(stream);
|
||||
^stream.collection
|
||||
}
|
||||
asLispExpression {
|
||||
^this.asLispString
|
||||
}
|
||||
storeLispOn { arg stream;
|
||||
stream << "#<" << this << ">"
|
||||
}
|
||||
}
|
||||
|
||||
+ Symbol {
|
||||
storeLispOn { arg stream;
|
||||
stream.putAll(this.asString)
|
||||
}
|
||||
}
|
||||
|
||||
+ String {
|
||||
asLispExpression {
|
||||
^this
|
||||
}
|
||||
storeLispOn { arg stream;
|
||||
stream.put($").putAll(this.escapeChar($")).put($")
|
||||
}
|
||||
}
|
||||
|
||||
+ Char {
|
||||
storeLispOn { arg stream;
|
||||
stream.putAll("?"++this)
|
||||
}
|
||||
}
|
||||
|
||||
+ Color {
|
||||
storeLispOn { arg stream;
|
||||
("#"++(red*255).asInteger.asHexString(2)
|
||||
++(green*255).asInteger.asHexString(2)
|
||||
++(blue*255).asInteger.asHexString(2)).storeLispOn(stream)
|
||||
}
|
||||
}
|
||||
|
||||
+ Number {
|
||||
storeLispOn { arg stream;
|
||||
stream << this
|
||||
}
|
||||
}
|
||||
|
||||
+ Nil {
|
||||
storeLispOn { arg stream;
|
||||
stream << "nil"
|
||||
}
|
||||
}
|
||||
|
||||
+ True {
|
||||
storeLispOn { arg stream;
|
||||
stream.put($t)
|
||||
}
|
||||
}
|
||||
|
||||
+ False {
|
||||
storeLispOn { arg stream;
|
||||
nil.storeLispOn(stream)
|
||||
}
|
||||
}
|
||||
|
||||
+ Association {
|
||||
storeLispOn { arg stream;
|
||||
stream.put($();
|
||||
this.key.storeLispOn(stream);
|
||||
stream.space.put($.).space;
|
||||
this.value.storeLispOn(stream);
|
||||
stream.put($));
|
||||
}
|
||||
}
|
||||
|
||||
+ Collection {
|
||||
lispDo { arg function;
|
||||
this.do(function);
|
||||
}
|
||||
|
||||
storeLispOn { arg stream;
|
||||
stream.put($();
|
||||
this.lispDo { arg x, i;
|
||||
if (i != 0) { stream.space };
|
||||
x.storeLispOn(stream);
|
||||
};
|
||||
stream.put($));
|
||||
}
|
||||
}
|
||||
|
||||
+ Dictionary {
|
||||
lispDo { arg function;
|
||||
this.associationsDo(function)
|
||||
}
|
||||
}
|
||||
|
||||
// EOF
|
||||
Loading…
Reference in a new issue