editors/scel/el/sclang-language.el

   1 ;; copyright 2003-2005 stefan kersten <steve@k-hornz.de>
   2 ;;
   3 ;; This program is free software; you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation; either version 2 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; This program is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with this program; if not, write to the Free Software
  15 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
  16 ;; USA
  17
  18 (eval-when-compile
  19   (require 'cl))
  20
  21 (require 'sclang-browser)
  22 (require 'sclang-interp)
  23 (require 'sclang-util)
  24
  25 ;; =====================================================================
  26 ;; regexp utilities
  27 ;; =====================================================================
  28
  29 (defun sclang-regexp-group (regexp &optional addressable)
  30   "Enclose REGEXP in grouping parentheses.
  31
  32 If ADDRESSABLE is non-nil the group match data can be addressed
  33 separately after matching."
  34   (concat "\\(" (unless addressable "?:") regexp "\\)"))
  35
  36 (defun sclang-regexp-concat (&rest regexps)
  37   "Concatenate REGEXPS by grouping.
  38
  39 The expressions are joined as alternatives with the \\| operator."
  40   (mapconcat 'sclang-regexp-group regexps "\\|"))
  41
  42 ;; =====================================================================
  43 ;; some useful regular expressions
  44 ;; =====================================================================
  45
  46 (defconst sclang-symbol-regexp
  47   "\\(?:\\sw\\|\\s_\\)*"
  48   "Regular expression matching symbols.")
  49
  50 (defconst sclang-identifier-regexp
  51   (concat "[a-z]" sclang-symbol-regexp)
  52   "Regular expression matching valid identifiers.")
  53
  54 (defconst sclang-method-name-special-chars
  55   "-!%&*+/<=>?@|"
  56   "Regular expression matching special method name characters.")
  57
  58 (defconst sclang-method-name-plain-regexp
  59   (concat sclang-identifier-regexp "_?")
  60   "Regular expression matching regular method names.")
  61
  62 (defconst sclang-method-name-special-regexp
  63   (concat
  64    "[" (regexp-quote sclang-method-name-special-chars) "]+")
  65    "Regular expression matching method names composed of special characters.")
  66
  67 (defconst sclang-method-name-regexp
  68   (sclang-regexp-concat
  69    sclang-method-name-special-regexp
  70    sclang-method-name-plain-regexp)
  71   "Regular expression matching method names.")
  72
  73 (defconst sclang-class-name-regexp
  74   "\\(?:Meta_\\)?[A-Z]\\(?:\\sw\\|\\s_\\)*"
  75   "Regular expression matching class names.")
  76
  77 (defconst sclang-primitive-name-regexp
  78   (concat "_[A-Z]" sclang-symbol-regexp)
  79   "Regular expression matching primitive names.")
  80
  81 (defconst sclang-symbol-name-regexp
  82   (sclang-regexp-concat
  83    sclang-method-name-regexp
  84    sclang-class-name-regexp)
  85   "Regular expression matching class and method names.")
  86
  87 (defconst sclang-class-definition-regexp
  88   (concat "^\\s *\\("
  89           sclang-class-name-regexp
  90           "\\)\\(?:\\s *:\\s *\\("
  91           sclang-class-name-regexp
  92           "\\)\\)?[[:space:]]*{")
  93   "Regular expression matching class definitions.")
  94
  95 (defconst sclang-method-definition-regexp
  96   (concat "^\\s *\\*?\\(" sclang-method-name-regexp "\\)\\s *{")
  97   "Regular expression matching method definitions.")
  98
  99 (defconst sclang-block-regexp
 100   "^\\((\\)\\s *\\(?:/[/*]?.*\\)?"
 101   "Regular expression matching the beginning of a code block.
 102
 103 A block is enclosed by parentheses where the opening parenthesis must
 104 be at the beginning of a line to avoid ambiguities.")
 105
 106 (defconst sclang-beginning-of-defun-regexp
 107     (sclang-regexp-concat
 108      sclang-class-definition-regexp
 109      sclang-block-regexp)
 110     "Regular expression matching the beginning of defuns.
 111
 112 The match is either the start of a class definition
 113 \(`sclang-class-definition-regexp') or the beginning of a code block
 114 enclosed by parenthesis (`sclang-block-regexp').")
 115
 116 (defconst sclang-method-definition-spec-regexp
 117   (concat (sclang-regexp-group sclang-class-name-regexp t)
 118           "-"
 119           (sclang-regexp-group sclang-method-name-regexp t))
 120   "Regular expression matching definition specifications.
 121
 122 A specification is of the form <class-name>-<method-name>.")
 123
 124 ;; =====================================================================
 125 ;; regexp building
 126 ;; =====================================================================
 127
 128 (defun sclang-make-class-definition-regexp (name)
 129   "Return a regular expression matching the class definition NAME."
 130   (concat "\\(" (regexp-quote name) "\\)"
 131           "\\(?:\\s *:\\s *\\(" sclang-class-name-regexp "\\)\\)?"
 132           "[[:space:]]*{"))
 133
 134 (defun sclang-make-class-extension-regexp (name)
 135   "Return a regular expression matching the class extension NAME."
 136   (concat "\\+\\s *\\(" (regexp-quote name) "\\)"
 137           "\\s *{"))
 138
 139 (defun sclang-make-method-definition-regexp (name)
 140   "Return a regular expression matching the method definition NAME."
 141   (concat "\\(" (regexp-quote name) "\\)\\s *{"))
 142
 143 ;; =====================================================================
 144 ;; string matching
 145 ;; =====================================================================
 146
 147 (defun sclang-string-match (regexp string)
 148   "Match REGEXP with STRING while preserving case."
 149   (let ((case-fold-search nil))
 150     (string-match regexp string)))
 151
 152 (defun sclang-symbol-match (symbol-regexp string)
 153   (sclang-string-match (concat "^" symbol-regexp "$") string))
 154
 155 ;; =====================================================================
 156 ;; symbol name predicates
 157 ;; =====================================================================
 158
 159 (defun sclang-class-name-p (string)
 160   (sclang-symbol-match sclang-class-name-regexp string))
 161
 162 (defun sclang-meta-class-name-p (string)
 163   (and (sclang-class-name-p string)
 164        (sclang-string-match "^Meta_" string)))
 165
 166 (defun sclang-method-name-p (string)
 167   (sclang-symbol-match sclang-method-name-regexp string))
 168
 169 (defun sclang-symbol-name-p (string)
 170   (sclang-symbol-match sclang-symbol-name-regexp string))
 171
 172 (defun sclang-method-name-setter-p (method-name)
 173   (string-match "_$" method-name))
 174
 175 (defun sclang-method-name-getter-p (method-name)
 176   (not (sclang-method-name-setter-p method-name)))
 177
 178 ;; =====================================================================
 179 ;; symbol name manipulation
 180 ;; =====================================================================
 181
 182 (defun sclang-method-name-setter (method-name)
 183   (if (sclang-method-name-setter-p method-name)
 184       method-name
 185     (concat method-name "_")))
 186
 187 (defun sclang-method-name-getter (method-name)
 188   (if (sclang-method-name-setter-p method-name)
 189       (substring method-name 0 (1- (length method-name)))
 190     method-name))
 191
 192 ;; =====================================================================
 193 ;; symbol table access
 194 ;; =====================================================================
 195
 196 (defcustom sclang-use-symbol-table t
 197   "*Retrieve symbol table upon library initialization.
 198
 199 Symbol table retrieval is performed each time the library is
 200 recompiled. This takes some time and the symbol table has to be held
 201 in memory, so it might be necessary to disable this option on
 202 low-resource systems."
 203   :group 'sclang-interface
 204   :version "21.3"
 205   :type 'boolean)
 206
 207 (defvar sclang-symbol-table nil
 208   "List of all defined symbols.")
 209
 210 (defvar sclang-symbol-history nil
 211   "List of recent symbols read from the minibuffer.")
 212
 213 (defvar sclang-symbol-table-file nil)
 214
 215 (sclang-set-command-handler
 216  'symbolTable
 217  (lambda (arg)
 218    (when (and sclang-use-symbol-table arg)
 219      (setq sclang-symbol-table (sort arg 'string<))
 220      (sclang-update-font-lock))))
 221
 222 (add-hook 'sclang-library-startup-hook
 223           (lambda ()
 224             (when sclang-use-symbol-table
 225               (let ((file (make-temp-file "sclang-symbol-table.")))
 226                 (when (and file (file-exists-p file))
 227                   (setq sclang-symbol-table-file file)
 228                   (sclang-perform-command 'symbolTable file))))))
 229
 230 (add-hook 'sclang-library-shutdown-hook
 231           (lambda ()
 232             (setq sclang-symbol-table nil)
 233             (sclang-update-font-lock)))
 234
 235 (defun sclang-get-symbol-completion-table ()
 236   (mapcar (lambda (s) (cons s nil)) sclang-symbol-table))
 237
 238 (defun sclang-make-symbol-completion-predicate (predicate)
 239   (and predicate (lambda (assoc) (funcall predicate (car assoc)))))
 240
 241 (defun sclang-get-symbol (string)
 242   (if (and sclang-use-symbol-table sclang-symbol-table)
 243       (car (member string sclang-symbol-table))
 244     string))
 245
 246 (defun sclang-read-symbol (prompt &optional default predicate require-match inherit-input-method)
 247   (if sclang-use-symbol-table
 248       (flet ((make-minibuffer-local-map
 249               (parent-keymap)
 250               (let ((map (make-sparse-keymap)))
 251                 (set-keymap-parent map parent-keymap)
 252                 ;; override keys bound to valid symbols
 253                 (define-key map [??] 'self-insert-command)
 254                 map)))
 255         (let ((symbol (sclang-get-symbol default))
 256               (minibuffer-local-completion-map (make-minibuffer-local-map
 257                                                 minibuffer-local-completion-map))
 258               (minibuffer-local-must-match-map (make-minibuffer-local-map
 259                                                 minibuffer-local-completion-map)))
 260           (completing-read (sclang-make-prompt-string prompt symbol)
 261                            (sclang-get-symbol-completion-table)
 262                            (sclang-make-symbol-completion-predicate predicate)
 263                            require-match nil
 264                            'sclang-symbol-history symbol
 265                            inherit-input-method)))
 266     (read-string (sclang-make-prompt-string prompt default) nil
 267                  'sclang-symbol-history default inherit-input-method)))
 268
 269 ;; =====================================================================
 270 ;; buffer movement
 271 ;; =====================================================================
 272
 273 (defun sclang-point-in-comment-p ()
 274   "Return non-nil if point is inside a comment.
 275
 276 Use font-lock information if font-lock-mode is enabled."
 277   (if (and (boundp 'font-lock-mode) (eval 'font-lock-mode))
 278       ;; use available information in font-lock-mode
 279       (eq (get-text-property (point) 'face) 'font-lock-comment-face)
 280     ;; else parse from the beginning
 281     (save-excursion
 282       (let ((beg (point)))
 283         (beginning-of-defun)
 284         (not (null (nth 4 (parse-partial-sexp (point) beg))))))))
 285
 286 (defun sclang-beginning-of-defun (&optional arg)
 287   (interactive "p")
 288   (let ((case-fold-search nil)
 289         (arg (or arg (prefix-numeric-value current-prefix-arg)))
 290         (orig (point))
 291         (success t))
 292     (while (and success (> arg 0))
 293       (setq success (re-search-backward sclang-beginning-of-defun-regexp
 294                                         nil 'move))
 295       (when (and success (not (sclang-point-in-comment-p)))
 296         (goto-char (match-beginning 0))
 297         (setq arg (1- arg))))
 298     (while (and success (< arg 0))
 299       (setq success (re-search-forward sclang-beginning-of-defun-regexp nil t))
 300       (when (and success (not (sclang-point-in-comment-p)))
 301         (goto-char (match-end 0))
 302         (setq arg (1+ arg))))
 303     (when success
 304       (beginning-of-line)
 305       (cond ((looking-at sclang-block-regexp) (goto-char (1- (match-end 1))))
 306             ((looking-at sclang-class-definition-regexp) (goto-char (1- (match-end 0)))))
 307       t)))
 308
 309 (defun sclang-point-in-defun-p ()
 310   "Return non-nil if point is inside a defun.
 311 Return value is nil or (beg end) of defun."
 312   (save-excursion
 313     (let ((orig (point))
 314           beg end)
 315       (and (progn (end-of-line) (beginning-of-defun-raw 1) t)
 316            (setq beg (point))
 317            (condition-case nil (forward-list 1) (error nil))
 318            (setq end (point))
 319            (list beg end)))))
 320
 321 (defun sclang-end-of-defun (&optional arg)
 322   (interactive "p")
 323   (let ((case-fold-search nil)
 324         (arg (or arg (prefix-numeric-value current-prefix-arg)))
 325         (success t)
 326         n cur)
 327     (while (and success (> arg 0))
 328       (setq n (if (sclang-point-in-defun-p) 1 -1))
 329       (setq cur (point))
 330       (if (and (sclang-beginning-of-defun n)
 331                (condition-case nil (forward-list 1) (error nil)))
 332           (progn
 333             (setq arg (1- arg)))
 334         (goto-char cur)
 335         (setq success nil)))
 336     (while (and success (< arg 0))
 337       (setq n (if (sclang-point-in-defun-p) 2 1))
 338       (setq cur (point))
 339       (if (and (sclang-beginning-of-defun n)
 340                (condition-case nil (forward-list 1) (error nil)))
 341           (progn
 342             (backward-char 1)
 343             (setq arg (1+ arg)))
 344         (goto-char cur)
 345         (setq success nil)))
 346     (when success
 347       (forward-line 1) t)))
 348
 349 ;; =====================================================================
 350 ;; buffer object access
 351 ;; =====================================================================
 352
 353 (defun sclang-symbol-at-point (&optional symbol-name-regexp)
 354   "Return the symbol at point, or nil if not a valid symbol.
 355
 356 The argument SYMBOL-NAME-REGEXP can be used to specify the type of
 357 symbol matched, candidates are `sclang-symbol-name-regexp' and
 358 `sclang-primitive-name-regexp', the default is
 359 `sclang-symbol-name-regexp'."
 360   (save-excursion
 361     (with-syntax-table sclang-mode-syntax-table
 362       (let ((case-fold-search nil)
 363             beg end)
 364         (cond ((looking-at sclang-method-name-special-regexp)
 365                (skip-chars-backward sclang-method-name-special-chars)
 366                (setq beg (point))
 367                (skip-chars-forward sclang-method-name-special-chars)
 368                (setq end (point)))
 369               (t
 370                (skip-syntax-backward "w_")
 371                (setq beg (point))
 372                (skip-syntax-forward "w_")
 373                (setq end (point))))
 374         (goto-char beg)
 375         (if (looking-at (or symbol-name-regexp sclang-symbol-name-regexp))
 376             (buffer-substring-no-properties beg end))))))
 377
 378 (defun sclang-line-at-point ()
 379   "Return the line at point."
 380   (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
 381
 382 (defun sclang-defun-at-point ()
 383   "Return the defun at point.
 384
 385 A defun may either be a class definition or a code block, see
 386 `sclang-beginning-of-defun-regexp'."
 387   (save-excursion
 388     (with-syntax-table sclang-mode-syntax-table
 389       (multiple-value-bind (beg end) (sclang-point-in-defun-p)
 390         (and beg end (buffer-substring-no-properties beg end))))))
 391
 392 ;; =====================================================================
 393 ;; symbol completion
 394 ;; =====================================================================
 395
 396 (defun sclang-complete-symbol (&optional predicate)
 397   "Perform completion on symbol preceding point.
 398 Compare that symbol against the known symbols.
 399
 400 When called from a program, optional arg PREDICATE is a predicate
 401 determining which symbols are considered.
 402 If PREDICATE is nil, the context determines which symbols are
 403 considered.  If the symbol starts with an upper case letter,
 404 class name completion is performed, otherwise only selector names
 405 are considered."
 406   (interactive)
 407   (let* ((buffer (current-buffer))
 408          (end (point))
 409          (beg (save-excursion
 410                 (backward-sexp 1)
 411                 (skip-syntax-forward "'")
 412                 (point)))
 413          (pattern (buffer-substring-no-properties beg end))
 414          (case-fold-search nil)
 415          (table (sclang-get-symbol-completion-table))
 416          (predicate (or predicate
 417                         (if (sclang-class-name-p pattern)
 418                             'sclang-class-name-p
 419                           'sclang-method-name-p)))
 420          (completion (try-completion pattern table (lambda (assoc) (funcall predicate (car assoc))))))
 421     (cond ((eq completion t))
 422           ((null completion)
 423            (sclang-message "Can't find completion for '%s'" pattern)
 424            (ding))
 425           ((not (string= pattern completion))
 426            (delete-region beg end)
 427            (insert completion))
 428           (t
 429            (sclang-message "Making completion list...")
 430            (let* ((list (all-completions pattern table (lambda (assoc) (funcall predicate (car assoc)))))
 431                   (win (selected-window))
 432                   (buffer-name (sclang-make-buffer-name "Completions"))
 433                   (same-window-buffer-names (list buffer-name)))
 434              (setq list (sort list 'string<))
 435              (with-sclang-browser
 436               buffer-name
 437               (add-hook 'sclang-browser-show-hook (lambda () (sclang-browser-next-link)))
 438               (setq sclang-browser-link-function
 439                     (lambda (arg)
 440                       (sclang-browser-quit)
 441                       (with-current-buffer (car arg)
 442                         (delete-region (car (cdr arg)) (point))
 443                         (insert (cdr (cdr arg))))))
 444               ;; (setq view-exit-action 'kill-buffer)
 445               (insert (format "Completions for '%s':\n\n" pattern))
 446               (dolist (x list)
 447                 (insert (sclang-browser-make-link x (cons buffer (cons beg x))))
 448                 (insert " \n"))))
 449            (sclang-message "Making completion list...%s" "done")))))
 450
 451 ;; =====================================================================
 452 ;; introspection
 453 ;; =====================================================================
 454
 455 (defcustom sclang-definition-marker-ring-length 32
 456   "*Length of marker ring `sclang-definition-marker-ring'."
 457   :group 'sclang-interface
 458   :version "21.3"
 459   :type 'integer)
 460
 461 (defvar sclang-definition-marker-ring
 462   (make-ring sclang-definition-marker-ring-length)
 463   "Ring of markers which are locations from which \\[sclang-find-definitions] was invoked.")
 464
 465 ;; really do that?
 466 (add-hook 'sclang-library-startup-hook
 467           (lambda ()
 468             (setq sclang-definition-marker-ring
 469                   (make-ring sclang-definition-marker-ring-length))))
 470
 471 (defun sclang-open-definition (name file pos &optional pos-func)
 472   (let ((buffer (find-file file)))
 473     (when (bufferp buffer)
 474       (with-current-buffer buffer
 475         (goto-char (or pos (point-min)))
 476         (when (and nil (functionp pos-func))
 477           (let ((pos (funcall pos-func name)))
 478             (and pos (goto-char pos))))))
 479     buffer))
 480
 481 (defun sclang-pop-definition-mark ()
 482   "Pop back to where \\[sclang-find-definition] or \\[sclang-find-reference] was last invoked."
 483   (interactive)
 484   (unless (ring-empty-p sclang-definition-marker-ring)
 485     (let ((marker (ring-remove sclang-definition-marker-ring 0)))
 486       (switch-to-buffer (or (marker-buffer marker)
 487                             (error "The marked buffer has been deleted")))
 488       (goto-char (marker-position marker))
 489       (set-marker marker nil nil))))
 490
 491 (defun sclang-browse-definitions (name definitions buffer-name header &optional pos-func)
 492   (if (cdr definitions)
 493       (let ((same-window-buffer-names (list buffer-name)))
 494         (with-sclang-browser
 495          buffer-name
 496          ;; (setq view-exit-action 'kill-buffer)
 497          (setq sclang-browser-link-function
 498                (lambda (data)
 499                  (sclang-browser-quit)
 500                  (apply 'sclang-open-definition data)))
 501          (add-hook 'sclang-browser-show-hook (lambda () (sclang-browser-next-link)))
 502          (insert header)
 503          (insert "\n")
 504          (let ((max-width 0)
 505                format-string)
 506            (dolist (def definitions)
 507              (setq max-width (max (length (file-name-nondirectory (nth 1 def))) max-width)))
 508            (setq format-string (format "%%-%ds  %%s" max-width))
 509            (dolist (def definitions)
 510              (let ((string (format format-string
 511                                    (propertize (file-name-nondirectory (nth 1 def)) 'face 'bold)
 512                                    (nth 0 def)))
 513                    (data (list name (nth 1 def) (nth 2 def) pos-func)))
 514                (insert (sclang-browser-make-link string data))
 515                (insert "\n"))))))
 516     ;; single definition: jump directly
 517     (let ((def (car definitions)))
 518       (sclang-open-definition name (nth 1 def) (nth 2 def) pos-func))))
 519
 520 (defun sclang-find-definitions (name)
 521   "Find all definitions of symbol NAME."
 522   (interactive
 523    (list
 524     (if current-prefix-arg
 525         (read-string "Find definition: ")
 526       (sclang-read-symbol "Find definitions of: "
 527                           (sclang-symbol-at-point) nil t))))
 528   (if (sclang-symbol-match sclang-method-definition-spec-regexp name)
 529       (sclang-perform-command 'openDefinition name)
 530     (if (sclang-get-symbol name)
 531         (progn
 532           (ring-insert sclang-definition-marker-ring (point-marker))
 533           (if (sclang-class-name-p name)
 534               (sclang-perform-command 'classDefinitions name)
 535             (sclang-perform-command 'methodDefinitions name)))
 536       (sclang-message "'%s' is undefined" name))))
 537
 538 (sclang-set-command-handler
 539  'openDefinition
 540  (lambda (assoc)
 541    (let ((name (car assoc))
 542          (data (cdr assoc)))
 543      (if data
 544          (sclang-open-definition nil (car data) (cadr data))
 545        (sclang-message "'%s' is undefined" name)))))
 546
 547 (sclang-set-command-handler
 548  'classDefinitions
 549  (lambda (assoc)
 550    (let ((name (car assoc))
 551          (data (cdr assoc)))
 552      (if data
 553          (sclang-browse-definitions
 554           name data
 555           "*Definitions*" (format "Definitions of '%s'\n" name)
 556           (lambda (name)
 557             (let ((case-fold-search nil))
 558               ;; point is either
 559               ;;  - at a class definition
 560               ;;  - inside a class extension
 561               ;; so jump to the class name
 562               (when (or (looking-at (sclang-make-class-definition-regexp name))
 563                         (re-search-backward (sclang-make-class-extension-regexp name) nil t))
 564                 (match-beginning 1)))))
 565        (sclang-message "No definitions of '%s'" name)))))
 566
 567 (sclang-set-command-handler
 568  'methodDefinitions
 569  (lambda (assoc)
 570    (let ((name (car assoc))
 571          (data (cdr assoc)))
 572      (if data
 573          (sclang-browse-definitions
 574           name data
 575           "*Definitions*" (format "Definitions of '%s'\n" name)
 576           (lambda (name)
 577             (let ((case-fold-search nil))
 578               (when (re-search-forward (sclang-make-method-definition-regexp name))
 579                 (match-beginning 1)))))
 580        (sclang-message "No definitions of '%s'" name)))))
 581
 582 (defun sclang-find-references (name)
 583   "Find all references to symbol NAME."
 584   (interactive
 585    (list
 586     (sclang-read-symbol "Find references to: "
 587                         (sclang-symbol-at-point) nil t)))
 588   (if (sclang-get-symbol name)
 589       (progn
 590         (ring-insert sclang-definition-marker-ring (point-marker))
 591         (sclang-perform-command 'methodReferences name))
 592     (sclang-message "'%s' is undefined" name)))
 593
 594 (sclang-set-command-handler
 595  'methodReferences
 596  (lambda (assoc)
 597    (let ((name (car assoc))
 598          (data (cdr assoc)))
 599      (if data
 600          (sclang-browse-definitions
 601           name data
 602           "*References*" (format "References to '%s'\n" name)
 603           (lambda (name)
 604             (let ((case-fold-search nil))
 605               (when (re-search-forward (regexp-quote name))
 606                 (match-beginning 0)))))
 607        (sclang-message "No references to '%s'" name)))))
 608
 609 (defun sclang-show-method-args ()
 610   "whooha. in full effect."
 611   (interactive)
 612   (let ((regexp (concat
 613                  sclang-class-name-regexp
 614                  "[ \t\n]*\\(?:\\.[ \t\n]*\\("
 615                  sclang-method-name-regexp
 616                  "\\)\\)?[ \t\n]*("))
 617         (case-fold-search nil)
 618         (beg (point)))
 619     (save-excursion
 620       (while (and (re-search-backward regexp nil t)
 621                   (let ((class (save-match-data (sclang-get-symbol (sclang-symbol-at-point)))))
 622                     (goto-char (1- (match-end 0)))
 623                     (if (condition-case nil
 624                             (save-excursion
 625                               (forward-list 1)
 626                               (> (point) beg))
 627                           (error t))
 628                         (let ((method (sclang-get-symbol (or (match-string-no-properties 1) "new"))))
 629                           (and class method
 630                                (sclang-perform-command 'methodArgs class method)
 631                                nil))
 632                       (goto-char (match-beginning 0)) t)))))))
 633
 634 (sclang-set-command-handler
 635  'methodArgs
 636  (lambda (args)
 637    (and args (message "%s" args))))
 638
 639 (defun sclang-dump-full-interface (class)
 640   "Dump interface of CLASS."
 641   (interactive
 642    (list
 643     (let* ((symbol (sclang-symbol-at-point))
 644            (class (and (sclang-get-symbol symbol)
 645                        (sclang-class-name-p symbol)
 646                        symbol)))
 647       (sclang-read-symbol "Dump interface of: "
 648                           class 'sclang-class-name-p t))))
 649   (sclang-eval-string (format "%s.dumpFullInterface" class)))
 650
 651 (defun sclang-dump-interface (class)
 652   "Dump interface of CLASS."
 653   (interactive
 654    (list
 655     (let* ((symbol (sclang-symbol-at-point))
 656            (class (and (sclang-get-symbol symbol)
 657                        (sclang-class-name-p symbol)
 658                        symbol)))
 659       (sclang-read-symbol "Dump interface of: "
 660                           class 'sclang-class-name-p t))))
 661   (sclang-eval-string (format "%s.dumpInterface" class)))
 662
 663 ;; =====================================================================
 664 ;; cscope interface
 665 ;; =====================================================================
 666
 667 (defcustom sclang-source-directory nil
 668   "Toplevel SuperCollider source directory.
 669
 670 This variable is used by `sclang-find-primitive' to locate the cscope
 671 database."
 672   :group 'sclang-interface
 673   :version "21.4.1"
 674   :type 'directory
 675   :options '(must-match))
 676
 677 (defun sclang-find-primitive (name)
 678   "Find primitive name a cscope database.
 679
 680 The database is searched in `sclang-source-directory', or the
 681 current-directory, iff `sclang-source-directoy' is nil."
 682   (interactive
 683    (let ((default (sclang-symbol-at-point sclang-primitive-name-regexp)))
 684      (list (read-string (sclang-make-prompt-string "Find primitive: " default)
 685                         nil nil default))))
 686   (if (require 'xcscope nil t)
 687       (let ((cscope-initial-directory sclang-source-directory))
 688         (cscope-find-this-text-string
 689          (if (string-match "^_" name) name (concat "_" name))))
 690     (sclang-message "cscope not available")))
 691
 692 ;; =====================================================================
 693 ;; sc-code formatting
 694 ;; =====================================================================
 695
 696 (defun sclang-list-to-string (list)
 697   (mapconcat 'sclang-object-to-string list ", "))
 698
 699 (defconst false 'false)
 700
 701 (defun sclang-object-to-string (obj)
 702   (cond ((null obj)
 703          "nil")
 704         ((eq false obj)
 705          "false")
 706         ((eq t obj)
 707          "true")
 708         ((symbolp obj)
 709          (format "'%s'" obj))
 710         ((listp obj)
 711          (format "[ %s ]" (sclang-list-to-string obj)))
 712         (t (format "%S" obj))))
 713
 714 (defun sclang-format (string &rest args)
 715   "format chars:
 716      %s - print string
 717      %o - print object
 718      %l - print argument list"
 719   (let ((case-fold-search nil)
 720         (i 0))
 721     (save-match-data
 722       (while (and (< i (length string))
 723                   (string-match "%[los%]" string i))
 724         (let* ((start (car (match-data)))
 725                (format (aref string (1+ start)))
 726                (arg (if args
 727                         (pop args)
 728                       (error "Not enough arguments for format string")))
 729                (repl (cond ((eq ?o format)
 730                             (sclang-object-to-string arg))
 731                            ((eq ?l format)
 732                             (if (listp arg)
 733                                 (sclang-list-to-string arg)
 734                               (sclang-object-to-string arg)))
 735                            ((eq ?s format)
 736                             (format "%s" arg))
 737                            ((eq ?% format)
 738                             (push arg args)
 739                             "%"))))
 740           (setq string (replace-match repl t t string))
 741           (setq i (+ start (length repl)))))))
 742   string)
 743
 744 (defun sclang-format-pseq (items)
 745   "Format ITEMS (a flat list of numbers or symbols) as a possibly nested Pseq.
 746 Looks for all repetitive patterns in ITEMS recursively.  Therefore, it is
 747 computationally expensive, especially when ITEMS is a long list.  If you don't
 748 want smart pattern guessing, use `sclang-format' directly to format your Pseq."
 749   (flet ((find-reps (items)
 750            (let (r)
 751              (while items
 752                (let ((ret (car items))
 753                      (skip 1)
 754                      (rep (length items)))
 755                  (catch 'match-found
 756                    (while (>= rep 2)
 757                      (let ((i (/ (length items) rep)))
 758                        (while (> i 0)
 759                          (let ((sublst (subseq items 0 i)))
 760                            (when (catch 'equal
 761                                    (let ((a items))
 762                                      (loop repeat rep do
 763                                            (let ((b sublst))
 764                                              (while b
 765                                                (unless (eql (car b) (car a))
 766                                                  (throw 'equal nil))
 767                                                (setq a (cdr a)
 768                                                      b (cdr b)))))
 769                                      t))
 770                              (setq ret (cons rep (if (> i 5)
 771                                                      (find-reps sublst)
 772                                                    sublst))
 773                                    skip (* i rep))
 774                              (throw 'match-found t))
 775                            (decf i))))
 776                      (decf rep)))
 777                  (accept-process-output nil 0 100)
 778                  (message "Processed...%S" ret) ;; invent better progress info
 779                  (setq r (append r (list ret))
 780                        items (nthcdr skip items))))
 781              r))
 782          (elem-to-string (elem)
 783            (cond
 784             ((consp elem)
 785              (concat "Pseq([ "
 786                      (mapconcat #'elem-to-string (cdr elem) ", ")
 787                      (format " ], %d)" (car elem))))
 788             (t (sclang-object-to-string elem)))))
 789     (let ((compressed (find-reps items)))
 790       (if (and (= (length compressed) 1) (consp (car compressed)))
 791           (elem-to-string (car compressed))
 792         (concat "Pseq([ "
 793                 (mapconcat #'elem-to-string compressed ", ")
 794                 " ], 1)")))))
 795
 796 ;; =====================================================================
 797 ;; module setup
 798 ;; =====================================================================
 799
 800 (provide 'sclang-language)
 801
 802 ;; EOF