commit 89fba7d16943fe9580fbe8700209b8af4aa1c309 Author: Marije Baalman Date: Fri Jan 2 19:06:25 2009 +0000 move scel to editors git-svn-id: https://supercollider.svn.sourceforge.net/svnroot/supercollider/trunk@8370 a380766d-ff14-0410-b294-a243070f3f08 diff --git a/README b/README new file mode 100644 index 0000000..f34d3f1 --- /dev/null +++ b/README @@ -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. + diff --git a/el/sclang-browser.el b/el/sclang-browser.el new file mode 100644 index 0000000..46e9f02 --- /dev/null +++ b/el/sclang-browser.el @@ -0,0 +1,183 @@ +;; copyright 2003 stefan kersten +;; +;; 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 \ No newline at end of file diff --git a/el/sclang-document.el b/el/sclang-document.el new file mode 100644 index 0000000..05e2958 --- /dev/null +++ b/el/sclang-document.el @@ -0,0 +1,20 @@ +;; copyright 2003 stefan kersten +;; +;; 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 \ No newline at end of file diff --git a/el/sclang-help.el b/el/sclang-help.el new file mode 100644 index 0000000..6b1ce93 --- /dev/null +++ b/el/sclang-help.el @@ -0,0 +1,651 @@ +;; copyright 2003 stefan kersten +;; +;; 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") + ("

\\(.*\\)

" . "
\\2
")) + "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") + ("

\\(.*\\)

" . "
\\2
")) + "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 diff --git a/el/sclang-interp.el b/el/sclang-interp.el new file mode 100644 index 0000000..478bab6 --- /dev/null +++ b/el/sclang-interp.el @@ -0,0 +1,713 @@ +;; copyright 2003-2005 stefan kersten +;; +;; 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 diff --git a/el/sclang-keys.el b/el/sclang-keys.el new file mode 100644 index 0000000..d714342 --- /dev/null +++ b/el/sclang-keys.el @@ -0,0 +1,42 @@ +;; copyright 2003 stefan kersten +;; +;; 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 + diff --git a/el/sclang-language.el b/el/sclang-language.el new file mode 100644 index 0000000..32f8de0 --- /dev/null +++ b/el/sclang-language.el @@ -0,0 +1,804 @@ +;; copyright 2003-2005 stefan kersten +;; +;; 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 -.") + +;; ===================================================================== +;; 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 diff --git a/el/sclang-menu.el b/el/sclang-menu.el new file mode 100644 index 0000000..99f525a --- /dev/null +++ b/el/sclang-menu.el @@ -0,0 +1,23 @@ +;; copyright 2003 stefan kersten +;; +;; 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) \ No newline at end of file diff --git a/el/sclang-minor-mode.el b/el/sclang-minor-mode.el new file mode 100644 index 0000000..d7745ad --- /dev/null +++ b/el/sclang-minor-mode.el @@ -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) + ) \ No newline at end of file diff --git a/el/sclang-mode.el b/el/sclang-mode.el new file mode 100644 index 0000000..e797ca0 --- /dev/null +++ b/el/sclang-mode.el @@ -0,0 +1,687 @@ +;; copyright 2003-2005 stefan kersten +;; +;; 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 diff --git a/el/sclang-server.el b/el/sclang-server.el new file mode 100644 index 0000000..c903023 --- /dev/null +++ b/el/sclang-server.el @@ -0,0 +1,277 @@ +;; copyright 2003-2005 stefan kersten +;; +;; 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 diff --git a/el/sclang-util.el b/el/sclang-util.el new file mode 100644 index 0000000..a7f6d82 --- /dev/null +++ b/el/sclang-util.el @@ -0,0 +1,86 @@ +;; copyright 2003-2005 stefan kersten +;; +;; 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 \ No newline at end of file diff --git a/el/sclang-vars.el.in b/el/sclang-vars.el.in new file mode 100644 index 0000000..29feaa0 --- /dev/null +++ b/el/sclang-vars.el.in @@ -0,0 +1,34 @@ +;;; sclang-vars.el --- Variables with build-time defaults + +;; Copyright (C) 2005 Free Software Foundation, Inc. + +;; Author: Mario Lang + +;; 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 diff --git a/el/sclang-widgets.el b/el/sclang-widgets.el new file mode 100644 index 0000000..f16ef37 --- /dev/null +++ b/el/sclang-widgets.el @@ -0,0 +1,162 @@ +;;; sclang-widgets.el --- Widget definitions for SCLang + +;; Copyright (C) 2005 Free Software Foundation, Inc. + +;; Author: mlang +;; 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 diff --git a/el/sclang.el b/el/sclang.el new file mode 100644 index 0000000..a4eee02 --- /dev/null +++ b/el/sclang.el @@ -0,0 +1,71 @@ +;;; sclang.el --- IDE for working with the SuperCollider language +;; copyright 2003 stefan kersten +;; +;; 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 diff --git a/el/tree-widget.el b/el/tree-widget.el new file mode 100644 index 0000000..8ee1d5f --- /dev/null +++ b/el/tree-widget.el @@ -0,0 +1,806 @@ +;;; tree-widget.el --- Tree widget + +;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. + +;; Author: David Ponce +;; Maintainer: David Ponce +;; 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 diff --git a/sc/Emacs.sc b/sc/Emacs.sc new file mode 100644 index 0000000..f9ed0bf --- /dev/null +++ b/sc/Emacs.sc @@ -0,0 +1,320 @@ +// copyright 2003 stefan kersten +// +// 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 keys; + classvar [ + '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 \ No newline at end of file diff --git a/sc/EmacsBuffer.sc b/sc/EmacsBuffer.sc new file mode 100644 index 0000000..bcd5133 --- /dev/null +++ b/sc/EmacsBuffer.sc @@ -0,0 +1,324 @@ +// Emacs Widget library bindings for SCLang + +EmacsBuffer { // Represents an Emacs buffer + classvar all; + var onClose, 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, ', \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, ', \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; + } +} diff --git a/sc/EmacsDocument.sc b/sc/EmacsDocument.sc new file mode 100644 index 0000000..cda3f91 --- /dev/null +++ b/sc/EmacsDocument.sc @@ -0,0 +1,307 @@ +// copyright 2003 stefan kersten +// +// 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 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) + } +} \ No newline at end of file diff --git a/sc/extBuffer.sc b/sc/extBuffer.sc new file mode 100644 index 0000000..28ff83c --- /dev/null +++ b/sc/extBuffer.sc @@ -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. + } +} diff --git a/sc/extClassBrowser.sc b/sc/extClassBrowser.sc new file mode 100644 index 0000000..2199de7 --- /dev/null +++ b/sc/extClassBrowser.sc @@ -0,0 +1,5 @@ ++ ClassBrowser{ + openSVN{ |svnAddr| + Emacs.evalLispExpression(['w3m-browse-url', svnAddr].asLispString); + } +} \ No newline at end of file diff --git a/sc/extDocument.sc b/sc/extDocument.sc new file mode 100644 index 0000000..3482d22 --- /dev/null +++ b/sc/extDocument.sc @@ -0,0 +1,73 @@ +// copyright 2003 stefan kersten +// +// 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 diff --git a/sc/homeContext.sc b/sc/homeContext.sc new file mode 100644 index 0000000..fb0c19a --- /dev/null +++ b/sc/homeContext.sc @@ -0,0 +1,5 @@ ++ FunctionDef { + homeContext { + ^if (context.isNil) { this } { context.homeContext } + } +} diff --git a/sc/storeLispOn.sc b/sc/storeLispOn.sc new file mode 100644 index 0000000..90f16fe --- /dev/null +++ b/sc/storeLispOn.sc @@ -0,0 +1,117 @@ +// copyright 2003 stefan kersten +// +// 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 \ No newline at end of file