cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/ilisp-src.el

   1 ;;; -*- Mode: Emacs-Lisp -*-
   2
   3 ;;; ilisp-src.el --
   4 ;;;
   5 ;;; This file is part of ILISP.
   6 ;;; Please refer to the file COPYING for copyrights and licensing
   7 ;;; information.
   8 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
   9 ;;; of present and past contributors.
  10 ;;;
  11 ;;; $Id: ilisp-src.el,v 1.4 2001-07-02 09:40:49 youngs Exp $
  12
  13 (require 'cl)
  14
  15 ;;; See ilisp.el for more information.
  16
  17 ;;;%Source file operations
  18 (unless (boundp 'tags-file-name)
  19   (defvar tags-file-name nil))
  20
  21 (defvar lisp-last-definition nil "Last definition (name type) looked for.")
  22
  23 (defvar lisp-last-file nil "Last used source file.")
  24
  25 (defvar lisp-first-point nil "First point found in last source file.")
  26
  27 (defvar lisp-last-point nil "Last point in last source file.")
  28
  29 (defvar lisp-last-locator nil "Last source locator used.")
  30
  31 (defvar lisp-search nil "Set to T when searching for definitions.")
  32
  33 (defvar lisp-using-tags nil "Set to T when using tags.")
  34
  35 ;;;%%lisp-directory
  36 (defvar lisp-edit-files t
  37   "Controls editing of of source files through Emacs' buffers.
  38 If T, then buffers in one of 'lisp-source-modes' will be searched by
  39 'edit-definitions-lisp' if the source cannot be found through the
  40 inferior LISP.  It can also be a list of files to edit definitions
  41 from set up by \(\\[lisp-directory]).  If it is set to nil, then no
  42 additional files will be searched.")
  43
  44 ;;;
  45 (defun lisp-extensions ()
  46   "Return a regexp for matching file extensions.
  47 The extensions are those of files that enter one of
  48 'lisp-source-modes' according to 'auto-mode-alist'."
  49   (let ((entries auto-mode-alist)
  50         (extensions nil))
  51     (dolist (entry entries)
  52       (when (memq (cdr entry) lisp-source-modes)
  53         (setq extensions
  54               (concat "\\|" (car entry) extensions))))
  55     (substring extensions 2)))
  56
  57 ;;;
  58 (defun lisp-directory (directory add)
  59   "Edit the files in DIRECTORY.
  60 The files must have an 'auto-mode' alist entry in 'lisp-source-modes'.
  61 With a positive prefix, add the files on to the already existing
  62 files.  With a negative prefix, clear the list.  In either case set
  63 tags-file-name to nil so that tags are not used."
  64   (interactive
  65    (list (if (not (eq current-prefix-arg '-))
  66              (read-file-name "Lisp Directory: "
  67                              nil
  68                              default-directory
  69                              nil))
  70              current-prefix-arg))
  71   (setq tags-file-name nil)
  72   (if (eq add '-)
  73       (progn (setq lisp-edit-files t)
  74              (message "No current lisp directory"))
  75       (if add
  76           (message "Added %s as a lisp directory" directory)
  77           (message "%s is the lisp directory" directory))
  78       (setq directory (expand-file-name directory))
  79       (if (file-directory-p directory)
  80           (setq lisp-edit-files
  81                 (append
  82                  (directory-files directory t (lisp-extensions))
  83                  (if add (if (eq lisp-edit-files t) nil lisp-edit-files))))
  84           (error "%s is not a directory" directory))))
  85
  86 ;;;%%Utilities
  87
  88 (defun fix-source-filenames ()
  89   "Apply the 'ilisp-source-directory-fixup-alist' to the current buffer.
  90 (The buffer should be *Edit-Definitions*) The aim is to change any
  91 pre-compiledsource-file locations to point to local source file
  92 locations.
  93
  94 See 'ilisp-source-directory-fixup-alist'."
  95   (let ((alist (ilisp-value 'ilisp-source-directory-fixup-alist t))
  96         cons)
  97     (if alist
  98         (save-excursion
  99           (while alist
 100             (setq cons (car alist))
 101             (goto-char (point-min))
 102             (if (re-search-forward (car cons) (point-max) t)
 103                 (replace-match (cdr cons)))
 104             (setq alist (cdr alist)))))))
 105
 106 (defun lisp-setup-edit-definitions (message edit-files)
 107   "Set up *Edit-Definitions* with MESSAGE.
 108 If EDIT-FILES is T, insert all buffer filenames that are in one of
 109 lisp-source-modes into the current buffer.  If it is a list of files
 110 set up by lisp-directory, insert those in the buffer.  If it is a
 111 string put that in the buffer."
 112
 113   ;; Note
 114   ;; 19990804 Marco Antoniotti
 115   ;; Are we sure we want to set 'lisp-using-tags' to nil?
 116   (setq lisp-using-tags nil
 117         lisp-search (not (stringp edit-files)))
 118   (set-buffer (get-buffer-create "*Edit-Definitions*"))
 119   (erase-buffer)
 120   (insert message)
 121   (insert "\n\n")
 122   (if edit-files
 123       (progn
 124         (if (eq edit-files t)
 125             (let ((buffers (buffer-list)))
 126               (while buffers
 127                 (let ((buffer (car buffers)))
 128                   (if (save-excursion
 129                         (set-buffer buffer)
 130                         (and (memq major-mode lisp-source-modes)
 131                              (buffer-file-name buffer)))
 132                       (progn (insert ?\") (insert (buffer-file-name buffer))
 133                              (insert "\"\n"))))
 134                 (setq buffers (cdr buffers))))
 135             (if (stringp edit-files)
 136                 (progn (insert edit-files)
 137                         ;; Remove garbage collection messages
 138                        (replace-regexp "^;[^\n]*\n" "")
 139                        (fix-source-filenames))
 140                 (let ((files edit-files))
 141                   (while files
 142                     (insert ?\")
 143                     (insert (car files))
 144                     (insert "\"\n")
 145                     (setq files (cdr files))))))
 146         (goto-char (point-min))
 147         (forward-line 2)
 148         (set-buffer-modified-p nil))
 149       (error
 150        (substitute-command-keys
 151         "Use \\[lisp-directory] to define source files."))))
 152
 153 ;;;
 154 (defun lisp-locate-definition (locator definition file point
 155                                        &optional
 156                                        back pop)
 157   "Use LOCATOR to find the next DEFINITION (symbol . type) in FILE.
 158 Search starts at POINT, optionally BACKWARDS and POP to buffer.  Return T
 159 if successful."
 160   (if file
 161       (if (not (file-exists-p file))
 162           (progn
 163             (message "File %s doesn't exist!" file)
 164             (sit-for 1)
 165             nil)
 166           (let* ((symbol (car definition))
 167                  (type (cdr definition))
 168                  (first (not (eq lisp-last-file file)))
 169                  (buffer (current-buffer))
 170                  name)
 171             (lisp-find-file file pop)
 172             (if first (setq lisp-first-point (point)))
 173             (if back
 174                 (if first
 175                     (goto-char (point-max))
 176                     (goto-char point)
 177                     (forward-line -1)
 178                     (end-of-line))
 179                 (goto-char point)
 180                 (if (not first)
 181                     (progn (forward-line 1) (beginning-of-line))))
 182             (if (eq type 't)
 183                 (message "Search %s for %s" file symbol)
 184                 (message "Searching %s for %s %s" file type
 185                          (setq name (lisp-buffer-symbol symbol))))
 186             (if (funcall locator symbol type first back)
 187                 (progn
 188                   (setq lisp-last-file file
 189                         lisp-last-point (point))
 190                   (if (bolp)
 191                       (forward-line -1)
 192                       (beginning-of-line))
 193                   (recenter 0)
 194                   (if name
 195                       (message "Found %s %s definition" type name)
 196                       (message "Found %s"))
 197                   t)
 198                 (if first
 199                     (goto-char lisp-first-point)
 200                     (set-buffer buffer)
 201                     (goto-char point))
 202                 nil)))))
 203
 204 ;;;
 205 (defun lisp-next-file (back)
 206   "Return the next filename in *Edit-Definitions*, or nil if none."
 207   (let ((file t)
 208         result)
 209     (set-buffer (get-buffer-create "*Edit-Definitions*"))
 210     (if back
 211         (progn (forward-line -1)
 212                (if (looking-at "\n")
 213                    (progn
 214                      (forward-line 1)
 215                      (end-of-line)
 216                      (setq file nil)))))
 217   (if file
 218       (progn
 219         (skip-chars-forward "^\"")
 220         (if (eobp)
 221             (progn (bury-buffer (current-buffer))
 222                    (setq result nil))
 223             (let* ((start (progn (forward-char 1) (point))))
 224               (skip-chars-forward "^\"")
 225               (setq file
 226                     (prog1 (buffer-substring start (point))
 227                       (end-of-line)))
 228               (bury-buffer (current-buffer))))))
 229   (if (not (eq file 't)) file)))
 230
 231 ;;;
 232 (defun lisp-next-definition (back pop)
 233   "Go to the next definition from *Edit-Definitions*.
 234 Movement is BACK with prefix and POPping.  Return 'first if found
 235 first time, 'none if no definition ever, T if another definition is
 236 found, and nil if no more definitions are found."
 237
 238   (let ((done nil)
 239         (result nil))
 240     (while
 241         (not
 242          (or
 243           (setq result
 244                 (lisp-locate-definition ;Same file
 245                  lisp-last-locator
 246                  lisp-last-definition lisp-last-file lisp-last-point back))
 247           (let ((file (lisp-next-file back)))
 248             (if file
 249                 (if (lisp-locate-definition
 250                      lisp-last-locator lisp-last-definition
 251                      file 1 back
 252                      (prog1 pop (setq pop nil)))
 253                     (setq result 'first)
 254                     (setq result (if (not lisp-search) 'none)))
 255                 t)))))
 256     (set-buffer (window-buffer (selected-window)))
 257     result))
 258
 259 ;;;%%Next-definition
 260 (defun next-definition-lisp (back &optional pop)
 261   "Edit the next definition from *Edit-Definitions*.
 262 Movement is BACK with prefix and optionally POPping or call
 263 'tags-loop-continue' if using tags."
 264   (interactive "P")
 265   (if lisp-using-tags
 266       (tags-loop-continue)
 267       (let* ((result (lisp-next-definition back pop))
 268              (symbol (car lisp-last-definition))
 269              (type (cdr lisp-last-definition))
 270              (name (if (not (eq type 't)) (lisp-buffer-symbol symbol))))
 271         (cond ((or (eq result 'first) (eq result 't))
 272                (if name
 273                    (message "Found %s %s definition" type name)
 274                    (message "Found %s" symbol)))
 275               ((eq result 'none)
 276                (error "Can't find %s %s definition" type name))
 277               (t
 278                (if name
 279                    (error "No more %s %s definitions" type name)
 280                    (message "Done")))))))
 281
 282
 283 ;;;%%Edit-definitions
 284 (defun edit-definitions-lisp (symbol type &optional stay search locator)
 285   "Find the source files for the TYPE definitions of SYMBOL.
 286 If STAY, use the same window.  If SEARCH, do not look for symbol in
 287 inferior LISP.  The definition will be searched for through the
 288 inferior LISP and if not found it will be searched for in the current
 289 tags file and if not found in the files in lisp-edit-files set up by
 290 \(\\[lisp-directory]) or the buffers in one of lisp-source-modes if
 291 lisp-edit-files is T.  If lisp-edit-files is nil, no search will be
 292 done if not found through the inferior LISP.  TYPES are from
 293 ilisp-source-types which is an alist of symbol strings or list
 294 strings.  With a negative prefix, look for the current symbol as the
 295 first type in ilisp-source-types."
 296   (interactive
 297    (let* ((types (ilisp-value 'ilisp-source-types t))
 298           (default (if types (car (car types))))
 299           (function (lisp-function-name))
 300           (symbol (lisp-buffer-symbol function)))
 301      (if (lisp-minus-prefix)
 302          (list function default)
 303          (list (ilisp-read-symbol
 304                 (format "Edit Definition [%s]: " symbol)
 305                 function
 306                 nil
 307                 t)
 308                (if types
 309                    (ilisp-completing-read
 310                     (format "Type [%s]: " default)
 311                     types default))))))
 312   (let* ((name (lisp-buffer-symbol symbol))
 313          (symbol-name (lisp-symbol-name symbol))
 314          (command (ilisp-value 'ilisp-find-source-command t))
 315          (source
 316           (if (and command (not search) (comint-check-proc ilisp-buffer))
 317               (ilisp-send
 318                (format command symbol-name
 319                        (lisp-symbol-package symbol)
 320                        type)
 321                (concat "Finding " type " " name " definitions")
 322                'source )
 323               "nil"))
 324          (result (and source (lisp-last-line source)))
 325          (source-ok (not (or (ilisp-value 'comint-errorp t)
 326                              (null result)
 327                              (string-match "nil" (car result)))))
 328          (case-fold-search t)
 329          (tagged nil))
 330     (unwind-protect
 331        (if (and tags-file-name (not source-ok))
 332            (progn (setq lisp-using-tags t)
 333                   (cond
 334                    (search
 335                     ;; Search through all files listed in tags table
 336                     (setq tags-loop-scan (list locator
 337                                                (list 'quote symbol)
 338                                                type t nil)
 339                           tags-loop-operate nil)
 340                     (tags-loop-continue t))
 341                    (t
 342                     ;; Use tags
 343                     (if (string-match "Lucid" emacs-version)
 344                         (find-tag symbol-name stay)
 345                       (find-tag symbol-name nil stay))))
 346                   (setq tagged t)))
 347        (if (not tagged)
 348            (progn
 349              (setq lisp-last-definition (cons symbol type)
 350                    lisp-last-file nil
 351                    lisp-last-locator (or locator (ilisp-value 'ilisp-locator)))
 352              (lisp-setup-edit-definitions
 353               (format "%s %s definitions:" type name)
 354               (if source-ok (cdr result) lisp-edit-files))
 355              (next-definition-lisp nil t))))))
 356
 357 ;;;%%Searching
 358 (defun lisp-locate-search (pattern type first back)
 359   "Find PATTERN in the current buffer."
 360   (if back
 361       (search-backward pattern nil t)
 362       (search-forward pattern nil t)))
 363
 364 ;;;
 365 (defun lisp-locate-regexp (regexp type first back)
 366   "Find REGEXP in the current buffer."
 367   (if back
 368       (re-search-backward regexp nil t)
 369       (re-search-forward regexp nil t)))
 370
 371 ;;;
 372
 373 (defvar lisp-last-pattern nil "Last search regexp.")
 374
 375 (defun search-lisp (pattern regexp)
 376   "Search for PATTERN through the files or buffers.
 377 Search for file in 'lisp-edit-files' if it is a list or the
 378 current buffers in one of 'lisp-source-modes' otherwise.  If
 379 lisp-edit-files is nil, no search will be done.  If called with a
 380 prefix, search for regexp.  If there is a tags file, call 'tags-search'
 381 instead."
 382   (interactive
 383    (list (read-string (if current-prefix-arg
 384                           "Search for regexp: "
 385                           "Search for: ") lisp-last-pattern)
 386          current-prefix-arg))
 387   (if tags-file-name
 388       (progn (setq lisp-using-tags t)
 389              (tags-search (if regexp pattern (regexp-quote pattern))))
 390       (setq lisp-last-pattern pattern
 391             lisp-last-definition (cons pattern t)
 392             lisp-last-file nil
 393             lisp-last-locator (if regexp
 394                                   'lisp-locate-regexp
 395                                   'lisp-locate-search))
 396       (lisp-setup-edit-definitions (format "Searching for %s:" pattern)
 397                                    lisp-edit-files)
 398       (next-definition-lisp nil nil)))
 399
 400 ;;;%%Replacing
 401 (defvar lisp-last-replace nil "Last replace regexp.")
 402
 403 (defun replace-lisp (old new regexp)
 404   "Query replace OLD by NEW through the files or the current buffers.
 405 The query is done in 'lisp-edit-files' if it is a list and the current
 406 buffers in one of 'lisp-source-modes' otherwise.  If 'lisp-edit-files'
 407 is NIL, no search will be done.  If called with a prefix, replace
 408 regexps.  If there is a tags file, then call tags-query-replace
 409 instead."
 410   (interactive
 411    (let ((old (read-string (if current-prefix-arg
 412                                "Replace regexp: "
 413                                "Replace: ") lisp-last-pattern)))
 414      (list old
 415            (read-string (if current-prefix-arg
 416                             (format "Replace regexp %s by: " old)
 417                             (format "Replace %s by: " old))
 418                         lisp-last-replace)
 419            current-prefix-arg)))
 420   (cond (tags-file-name
 421          (setq lisp-using-tags t)
 422          (tags-query-replace (if regexp old (regexp-quote old))
 423                              new))
 424         (t
 425          (setq lisp-last-pattern old
 426                lisp-last-replace new)
 427          (lisp-setup-edit-definitions
 428           (format "Replacing %s by %s:\n\n" old new)
 429           lisp-edit-files)
 430          (let ((file nil))
 431            (while (setq file (lisp-next-file nil))
 432              (lisp-find-file file)
 433              (let ((point (point)))
 434                (goto-char (point-min))
 435                (if (if regexp
 436                        (re-search-forward old nil t)
 437                        (search-forward old nil t))
 438                    (progn (beginning-of-line)
 439                           (if regexp
 440                               (query-replace-regexp old new)
 441                               (query-replace old new)))
 442                    (goto-char point))))))))
 443
 444 ;;;%%Edit-callers
 445 (defvar lisp-callers nil
 446   "T if we found callers through inferior LISP.")
 447
 448 ;;;
 449 (defun who-calls-lisp (function &optional no-show)
 450   "Put the functions that call FUNCTION into the buffer *All-Callers*.
 451 Show the buffer *All-Callers* unless NO-SHOW is T.  Return T if successful."
 452   (interactive
 453    (let* ((function (lisp-defun-name))
 454           (symbol (lisp-buffer-symbol function)))
 455      (if (lisp-minus-prefix)
 456          (list function)
 457          (list (ilisp-read-symbol
 458                 (format "Who Calls [%s]: " symbol)
 459                 function
 460                 t t)))))
 461   (let* ((name (lisp-buffer-symbol function))
 462          (command (ilisp-value 'ilisp-callers-command t))
 463          (callers
 464           (if command
 465               (ilisp-send
 466                (format command
 467                        (lisp-symbol-name function)
 468                        (lisp-symbol-package function))
 469                (concat "Finding callers of " name)
 470                'callers)))
 471          (last-line (if callers (lisp-last-line callers)))
 472          (case-fold-search t))
 473     (set-buffer (get-buffer-create "*All-Callers*"))
 474     (erase-buffer)
 475     (insert (format "All callers of function %s:\n\n" name))
 476     (if (and command (not (ilisp-value 'comint-errorp t)))
 477         (if (string-match "nil" (car last-line))
 478             (error "%s has no callers" name)
 479             (message "")
 480             (insert (cdr last-line))
 481             (goto-char (point-min))
 482             ;; Remove garbage collection messages
 483             (replace-regexp "^;[^\n]*\n" "")
 484             (goto-char (point-min))
 485             (forward-line 2)
 486             (if (not no-show)
 487                 (if (ilisp-temp-buffer-show-function)
 488                     (funcall (ilisp-temp-buffer-show-function)
 489                              (get-buffer "*All-Callers*"))
 490                     (view-buffer "*All-Callers*")))
 491             t)
 492         (insert "Using the current source files to find callers.")
 493         nil)))
 494
 495 ;;;
 496 (defun next-caller-lisp (back &optional pop)
 497   "Edit the next caller from *All-Callers*.
 498 With prefix, edit the previous caller.  If it can't get caller
 499 information from the inferior LISP, this will search using the current
 500 source files.  See lisp-directory."
 501
 502   (interactive "P")
 503   (if (not lisp-callers)
 504       (next-definition-lisp back pop)
 505       (set-buffer (get-buffer-create "*All-Callers*"))
 506       (if back (forward-line -1))
 507       (skip-chars-forward " \t\n")
 508       (if (eobp)
 509           (progn
 510             (bury-buffer (current-buffer))
 511             (error "No more callers"))
 512           (let* ((start (point))
 513                  (caller-function
 514                   (progn
 515                     (skip-chars-forward "^ \t\n")
 516                     (buffer-substring start (point)))))
 517             (bury-buffer (current-buffer))
 518             (edit-definitions-lisp (lisp-string-to-symbol caller-function)
 519                                   (car (car (ilisp-value 'ilisp-source-types)))
 520                                   (not pop))))))
 521
 522 ;;;
 523 (defun edit-callers-lisp (function)
 524   "Edit the callers of FUNCTION.
 525 With a minus prefix use the symbol at the start of the current defun."
 526   (interactive
 527    (let* ((function (lisp-defun-name)))
 528      (if (lisp-minus-prefix)
 529          (list function)
 530          (list (ilisp-read-symbol
 531                 (format "Edit callers of [%s]: "
 532                         (lisp-buffer-symbol function))
 533                 function
 534                 t)))))
 535   (if (save-excursion (setq lisp-callers (who-calls-lisp function t)))
 536       (progn
 537         (setq lisp-last-locator (ilisp-value 'ilisp-calls-locator))
 538         (next-caller-lisp nil t))
 539       (edit-definitions-lisp function "calls" nil t
 540                             (ilisp-value 'ilisp-calls-locator))))
 541
 542 ;;;%Locators
 543 (defun lisp-re (back format &rest args)
 544   "Search BACK if T using FORMAT applied to ARGS."
 545   (let ((regexp (apply 'format format args)))
 546     (if back
 547         (re-search-backward regexp nil t)
 548         (re-search-forward regexp nil t))))
 549
 550 ;;;
 551 (defun lisp-locate-ilisp (symbol type first back)
 552   "Find SYMBOL's TYPE definition in the current file.
 553 Return T if successful.  A definition is of the form
 554 \(def<whitespace>(?name<whitespace>."
 555   (lisp-re back
 556            "^[ \t\n]*(def[^ \t\n]*[ \t\n]+(?%s[ \t\n(]+"
 557            (regexp-quote (lisp-symbol-name symbol))))
 558
 559 ;;;
 560 (defun lisp-locate-calls (symbol type first back)
 561   "Locate calls to SYMBOL."
 562   (lisp-re back "\\(#'\\|(\\|'\\)%s\\([ \t\n]+\\|)\\)"
 563            (regexp-quote (lisp-buffer-symbol symbol))))
 564
 565
 566 ;;;%%Common LISP
 567
 568 ;;; ilisp-cl-source-locater-patterns --
 569 ;;;
 570 ;;; Note:
 571 ;;;
 572 ;;; 19990804 Marco Antoniotti
 573 ;;; The new ones (method and generic-fucntion) should be carefully checked.
 574
 575 (defvar ilisp-cl-source-locater-patterns
 576   '((setf
 577      "^\\(\ 6.\\)?[ \t\n]*(def[^ \t\n\ 6]*\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)(setf\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n]*\\(\ 6.\\)?[ \t\n]*)")
 578
 579     (function
 580      "^\\(\ 6.\\)?[ \t\n]*(defun\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 581
 582     (macro
 583      "^\\(\ 6.\\)?[ \t\n]*(defmacro\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 584
 585     (variable
 586      "^\\(\ 6.\\)?[ \t\n]*(def\\(\\(var\\)\\|\\(parameter\\)\\|constant\\)\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 587
 588     (structure
 589      "^\\(\ 6.\\)?[ \t\n]*(defstruct\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)(?[ \t\n]*\\(\ 6.\\)?[ \t\n]*%s[ \t\n(\ 6]")
 590
 591     (type
 592      "^\\(\ 6.\\)?[ \t\n]*(deftype\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 593
 594     (class
 595      "^\\(\ 6.\\)?[ \t\n]*(defclass\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 596
 597     (method
 598      "^\\(\ 6.\\)?[ \t\n]*(defmethod\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 599
 600     (generic-function
 601      "^\\(\ 6.\\)?[ \t\n]*(defgeneric\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n(\ 6]")
 602     ))
 603
 604
 605 (defun ilisp-locate-clisp-defn (name type back)
 606   (let ((pattern (car (cdr (assoc (intern type)
 607                                   ilisp-cl-source-locater-patterns)))))
 608     (when pattern
 609       (lisp-re back pattern name))))
 610
 611
 612
 613 (defun ilisp-locate-clos-method (name type back)
 614   (if (string-match "(\\([^(]*\\)\\(([^)]*)\\)" type)
 615       (let* ((quals (substring type (match-beginning 1) (match-end 1)))
 616              (class
 617               (read (substring type (match-beginning 2) (match-end 2))))
 618              (class-re nil)
 619              (position 0))
 620         (while (setq position (string-match
 621                                "\\([ \t\n]+\ 6.[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\|[ \t\n]+\\)"
 622                                quals position))
 623           (setq quals
 624                 (concat (substring quals 0 position)
 625                         "\\([ \t\n]+\ 6.[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\|[ \t\n]+\\)"
 626                         (substring quals (match-end 0)))))
 627         (while class
 628           (setq class-re
 629                 (concat
 630                  class-re
 631                  (format
 632                   "[ \t\n]*\\(\ 6.\\)?[ \t\n]*([ \t\n]*\\(\ 6.\\)?[ \t\n]*[^ \t\n\ 6]*\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n]*\\(\ 6.\\)?[ \t\n]*"
 633                   (car class)))
 634                 class (cdr class)))
 635         (lisp-re back
 636                  "^\\(\ 6.\\)?[ \t\n]*(def[^ \t\n\ 6]*\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[^ \t\n\ 6]*([^ \t\n\ 6]*%s"
 637                  name quals class-re))))
 638
 639
 640
 641
 642 (defun lisp-locate-clisp (symbol type first back)
 643   "Try to find SYMBOL's TYPE definition in the current buffer.
 644 Return T if sucessful.  FIRST is T if this is the first time in a
 645 file.  BACK is T to go backwards."
 646
 647   (let* ((name (regexp-quote (lisp-symbol-name symbol)))
 648          (prefix
 649           ;; Automatically generated defstruct accessors
 650           (if (string-match "-" name)
 651               (let ((struct (substring name 0 (1- (match-end 0)))))
 652                 (format
 653                  "^\\(\ 6.\\)?[ \t\n]*(def[^ \t\n\ 6]*\\([ \t\n]+\\(\ 6.\\)?\\|\\|[ \t\n]*\ 6.[ \t\n]+\\)(?%s[ \t\n)\ 6]\\|:conc-name\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s-"
 654                  struct struct))))
 655          ;; Defclass accessors
 656          (class
 657           "\\(:accessor\\|:writer\\|:reader\\)\\([ \t\n]+\\(\ 6.\\)?+[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)%s[ \t\n)\ 6]"))
 658     (or
 659      (if (equal type "any")
 660          (lisp-re
 661           back
 662           (concat
 663            "^\\(\ 6.\\)?[ \t\n]*(def[^ \t\n\ 6]*\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)\\((setf\\([ \t\n]+\\(\ 6.\\)?[ \t\n]*\\|[ \t\n]*\ 6.[ \t\n]+\\)\\|(?[ \t\n]*\\(\ 6.\\)?[ \t\n]*\\)%s[ \t\n)\ 6]"
 664            (if prefix (concat "\\|" prefix))
 665            "\\|"
 666            class)
 667           name name))
 668
 669      ;; (qualifiers* (type1 type2 ...))
 670      (ilisp-locate-clos-method name type back)
 671
 672      (ilisp-locate-clisp-defn name type back)
 673
 674      ;; Standard def form
 675      (when first (lisp-locate-ilisp symbol type first back))
 676      ;; Automatically generated defstruct accessors
 677      (when (and first prefix) (lisp-re back prefix))
 678      ;; Defclass accessors
 679      (lisp-re back class name)
 680      ;; Give up!
 681      )))
 682
 683 ;;;%% Locators for Scheme
 684
 685 ;;; Matthias Koeppe <mail.math.uni-magdeburg.de>
 686 ;;;
 687 ;;; The standard locators would fail on "(define (thunk) ....)"  and
 688 ;;; report "(define (procedure ...) ....)" as a call to procedure.
 689
 690 (defun ilisp-locate-scheme-definition (symbol type first back)
 691   "Find SYMBOL's TYPE definition in the current file. Return T if successful.
 692 This is the Scheme counterpart of `lisp-locate-ilisp'."
 693   (lisp-re back
 694            "[ \t\n]*(def[^ \t\n]*[ \t\n]+(*%s\[ \t\n()]"
 695            (regexp-quote (lisp-symbol-name symbol))))
 696
 697 (defun ilisp-locate-scheme-calls (symbol type first back)
 698   "Locate calls to SYMBOL.
 699 This is the Scheme counterpart of `lisp-locate-calls'."
 700   (let ((call-regexp
 701          (format "[( \t\n]+%s[ \t\n()]+"
 702                  (regexp-quote
 703                   ;; Scheme has no package prefixes, so we use
 704                   ;; lisp-symbol-name instead of lisp-buffer-symbol.
 705                   (lisp-symbol-name symbol))))
 706         (def-regexp "[ \t\n]*(def[^ \t\n]*[ \t\n]+(*")
 707         (result 'unknown))
 708     (while (eq result 'unknown)
 709       (cond
 710        ((if back
 711             (re-search-backward call-regexp nil t)
 712           (re-search-forward call-regexp nil t))
 713         (if (not (save-excursion        ; check whether definition
 714                    (goto-char (match-beginning 0))
 715                    (backward-sexp) (backward-char)
 716                    (looking-at def-regexp)))
 717             (setq result t)))
 718        (t (setq result nil))))
 719     result))
 720
 721
 722 ;;; end of file -- ilisp-src.el --