cgit.sxemacs.org Git - packages/blob - xemacs-packages/jde/lisp/efc.el

   1 ;;; efc.el -- Emacs Foundation Classes
   2 ;; $Revision: 1.18 $ $Date: 2005/03/19 03:50:31 $
   3
   4 ;; Author: Paul Kinnucan <paulk@mathworks.com>
   5 ;; Maintainer: Paul Kinnucan
   6 ;; Keywords: lisp, tools, classes
   7
   8 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005 Paul Kinnucan.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, US
  24 ;;; Commentary:
  25
  26 ;; This package contains a set of eieio-based foundation classes
  27 ;; for Emacs.
  28
  29 ;; Please send bug reports and enhancement suggestions
  30 ;; to Paul Kinnucan at <paulk@mathworks.com>
  31
  32 ;; See end of this file for change history.
  33
  34 ;;; Code:
  35
  36 (require 'eieio)
  37 (require 'wid-edit)
  38
  39 (defvar efc-query-options-function nil
  40   "If non-nil the function to use for interactively querying options.
  41 If nil then the default efc custom-based dialogs will be used.")
  42
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;                                                                            ;;
  45 ;; Dialog Class                                                               ;;
  46 ;;                                                                            ;;
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48
  49 (defclass efc-dialog ()
  50   ((title     :initarg :title
  51               :type string
  52               :initform "Dialog"
  53               :documentation
  54               "Title of dialog")
  55    (buf       :initarg :buf
  56               :type buffer
  57               :documentation
  58               "Dialog buffer")
  59    (initbuf   :initarg :initbuf
  60               :type buffer
  61               :documentation
  62               "Buffer from which dialog was called.")
  63    )
  64   "Super class of EFC dialogs."
  65   )
  66
  67 (defmethod initialize-instance ((this efc-dialog) &rest fields)
  68   "Constructor for dialog."
  69   ;; Call parent initializer.
  70   (call-next-method))
  71
  72
  73 (defmethod efc-dialog-create ((this efc-dialog)))
  74
  75 (defmethod efc-dialog-ok ((this efc-dialog))
  76   "Invoked when the user clicks the dialog's okay button. The
  77 default method kills the dialog buffer."
  78   (kill-buffer (current-buffer)))
  79
  80 (defmethod efc-dialog-cancel ((this efc-dialog))
  81   "Invoked when the user clicks the dialog's Cancel button. The
  82 default method kills the dialog buffer."
  83   (delete-window)
  84   (set-buffer (oref this initbuf))
  85   (pop-to-buffer (oref this initbuf))
  86   (kill-buffer (oref this buf)))
  87
  88 (defmethod efc-dialog-show ((this efc-dialog))
  89   (oset this initbuf (current-buffer))
  90
  91   (oset this buf (get-buffer-create (oref this title)))
  92   (set-buffer (oref this buf))
  93
  94   (efc-dialog-create this)
  95
  96   (widget-put
  97    (widget-create
  98     'push-button
  99     :notify
 100     (lambda (button &rest ignore) (efc-dialog-ok (widget-get button :dialog)))
 101     "Ok")
 102    :dialog this)
 103
 104   (widget-insert "  ")
 105
 106   (widget-put
 107    (widget-create
 108     'push-button
 109     :notify (lambda (button &rest ignore) (efc-dialog-cancel (widget-get button :dialog)))
 110     "Cancel")
 111    :dialog this)
 112
 113    (use-local-map widget-keymap)
 114    (widget-setup)
 115
 116   ;; Position cursor over OK button.
 117   ;; (forward-line 0)
 118
 119   (goto-char (point-min))
 120
 121   (pop-to-buffer (oref this buf)))
 122
 123
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;;                                                                            ;;
 126 ;; Option Dialog                                                              ;;
 127 ;;                                                                            ;;
 128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 129
 130 (defclass efc-option-dialog (efc-dialog)
 131   ((options        :initarg :options
 132                    :documentation
 133                    "Options from from which to choose.")
 134    (radio-buttons  :initarg :radio-buttons
 135                    :documentation
 136                    "Buttons for selecting options.")
 137    (text           :initarg :text
 138                    :type string
 139                    :initform "Select option."
 140                    :documentation
 141                    "Text to be inserted at top of dialog.")
 142    (selection      :initarg :selection
 143                    :documentation
 144                    "Option chosen by the user."))
 145    "This dialog allows a user to choose one of a set of OPTIONS by clicking
 146 a radio button next to the option. The dialog sets SELECTION to the option
 147 chosen by the user when the user selects the OK button on the dialog. This
 148 dialog uses recursive edit to emulate a modal dialog.")
 149
 150 (defmethod initialize-instance ((this efc-option-dialog) &rest fields)
 151   "Dialog constructor."
 152   (call-next-method))
 153
 154 (defmethod efc-dialog-create ((this efc-option-dialog))
 155   (widget-insert (oref this text))
 156   (widget-insert "\n\n")
 157   (oset this radio-buttons
 158         (widget-create
 159          (list
 160           'radio-button-choice
 161           :value (car (oref this options))
 162           :args (mapcar
 163                  (lambda (x)
 164                    (list 'item x))
 165                  (oref this options)))))
 166   (widget-insert "\n"))
 167
 168 (defmethod efc-dialog-show ((this efc-option-dialog))
 169   "Shows the options dialog buffer. After showing the dialog buffer,
 170 this method invokes recursive-edit to emulate the behavior of a modal
 171 dialog. This suspends the current command until the user has selected
 172 an option or canceled the dialog. See `efc-dialog-ok' and
 173 `efc-dialog-cancel' for more information."
 174   (save-window-excursion
 175     (call-next-method)
 176     (recursive-edit)))
 177
 178
 179 (defmethod efc-dialog-ok ((this efc-option-dialog))
 180   "Invoked when the user selects the OK button on the options
 181 dialog. Sets the :selection field of THIS to the option chosen by the
 182 user, kills the dialog buffer, and exits recursive-edit mode."
 183   (oset this
 184         selection
 185         (widget-value (oref this radio-buttons)))
 186   (delete-window)
 187   (set-buffer (oref this initbuf))
 188   (pop-to-buffer (oref this initbuf))
 189   (kill-buffer (oref this buf))
 190   (exit-recursive-edit))
 191
 192 (defmethod efc-dialog-cancel ((this efc-option-dialog))
 193   "Invoked when the user clicks the dialog's Cancel button.  Invokes
 194 the default cancel method, sets the :selection field of THIS to nil,
 195 and then exits recursive edit mode."
 196   (call-next-method)
 197   (oset this selection nil)
 198   (exit-recursive-edit))
 199
 200 (defun efc-query-options (options &optional prompt title)
 201   "Ask user to choose among a set of options."
 202   (if efc-query-options-function
 203       (funcall efc-query-options-function options prompt title)
 204     (let ((dialog
 205            (efc-option-dialog
 206             (or title "option dialog")
 207             :text (or prompt "Select option:")
 208             :options options)))
 209       (efc-dialog-show dialog)
 210       (oref dialog selection))))
 211
 212 ;; The following code is a patch that implements Richard Stallman's fix
 213 ;; for the following error that occurs only in Emacs 21.1.1.
 214 ;;
 215 ;; Debugger entered--Lisp error: (wrong-type-argument window-live-p #<window 66>)
 216 ;;      select-window(#<window 66>)
 217 ;;      exit-recursive-edit()
 218 ;; This replacement macro fixes the problem with exit-recursive-edit on Emacs 21.
 219 ;; You'll have to recompile wid-edit.el with it.
 220 ;; (defmacro save-selected-window (&rest body)
 221 ;;   "Execute BODY, then select the window that was selected before BODY.
 222 ;; However, if that window has become dead, don't get an error,
 223 ;; just refrain from switching to it."
 224 ;;   `(let ((save-selected-window-window (selected-window)))
 225 ;;      (unwind-protect
 226 ;;       (progn ,@body)
 227 ;;        (if (window-live-p save-selected-window-window)
 228 ;;         (select-window save-selected-window-window)))))
 229
 230
 231 (if (and (not (featurep 'xemacs))
 232          (or
 233           (string-match "21\\.1" (emacs-version))
 234           (string-match "21\\.2" (emacs-version))))
 235     (progn
 236       ;; Need to load wid-edit first to ensure that
 237       ;; it does not get loaded after this patch and
 238       ;; hence override the patch.
 239       (require 'wid-edit)
 240
 241       ;; Patched version of save-selected-window.
 242       (defmacro save-selected-window (&rest body)
 243         "Execute BODY, then select the window that was selected before BODY.
 244 However, if that window has become dead, don't get an error,
 245 just refrain from switching to it."
 246         `(let ((save-selected-window-window (selected-window)))
 247            (unwind-protect
 248                (progn ,@body)
 249              (if (window-live-p save-selected-window-window)
 250                  (select-window save-selected-window-window)))))
 251
 252       ;; Redefine widget-button-click to use the patched
 253       ;; version of save-selected-window
 254       (defun widget-button-click (event)
 255         "Invoke the button that the mouse is pointing at."
 256         (interactive "@e")
 257         (if (widget-event-point event)
 258             (let* ((pos (widget-event-point event))
 259                    (button (get-char-property pos 'button)))
 260               (if button
 261                   ;; Mouse click on a widget button.  Do the following
 262                 ;; in a save-excursion so that the click on the button
 263                   ;; doesn't change point.
 264                   (save-selected-window
 265                     (save-excursion
 266                       (mouse-set-point event)
 267                       (let* ((overlay (widget-get button :button-overlay))
 268                              (face (overlay-get overlay 'face))
 269                              (mouse-face (overlay-get overlay 'mouse-face)))
 270                         (unwind-protect
 271                        ;; Read events, including mouse-movement events
 272                       ;; until we receive a release event.  Highlight/
 273                      ;; unhighlight the button the mouse was initially
 274                             ;; on when we move over it.
 275                             (let ((track-mouse t))
 276                               (save-excursion
 277                                 (when face ; avoid changing around image
 278                                   (overlay-put overlay
 279                                                'face widget-button-pressed-face)
 280                                   (overlay-put overlay
 281                                                'mouse-face widget-button-pressed-face))
 282                                 (unless (widget-apply button :mouse-down-action event)
 283                                   (while (not (widget-button-release-event-p event))
 284                                     (setq event (read-event)
 285                                           pos (widget-event-point event))
 286                                     (if (and pos
 287                                              (eq (get-char-property pos 'button)
 288                                                  button))
 289                                         (when face
 290                                           (overlay-put overlay
 291                                                        'face
 292                                                        widget-button-pressed-face)
 293                                           (overlay-put overlay
 294                                                        'mouse-face
 295                                                        widget-button-pressed-face))
 296                                       (overlay-put overlay 'face face)
 297                                       (overlay-put overlay 'mouse-face mouse-face))))
 298
 299                         ;; When mouse is released over the button, run
 300                                 ;; its action function.
 301                                 (when (and pos
 302                                            (eq (get-char-property pos 'button) button))
 303                                   (widget-apply-action button event))))
 304                           (overlay-put overlay 'face face)
 305                           (overlay-put overlay 'mouse-face mouse-face))))
 306
 307                     (unless (pos-visible-in-window-p (widget-event-point event))
 308                       (mouse-set-point event)
 309                       (beginning-of-line)
 310                       (recenter)))
 311
 312                 (let ((up t) command)
 313                ;; Mouse click not on a widget button.  Find the global
 314                 ;; command to run, and check whether it is bound to an
 315                   ;; up event.
 316                   (mouse-set-point event)
 317                   (if (memq (event-basic-type event) '(mouse-1 down-mouse-1))
 318                       (cond ((setq command ;down event
 319                                    (lookup-key widget-global-map [down-mouse-1]))
 320                              (setq up nil))
 321                             ((setq command ;up event
 322                                    (lookup-key widget-global-map [mouse-1]))))
 323                     (cond ((setq command ;down event
 324                                  (lookup-key widget-global-map [down-mouse-2]))
 325                            (setq up nil))
 326                           ((setq command ;up event
 327                                  (lookup-key widget-global-map [mouse-2])))))
 328                   (when up
 329                     ;; Don't execute up events twice.
 330                     (while (not (widget-button-release-event-p event))
 331                       (setq event (read-event))))
 332                   (when command
 333                     (call-interactively command)))))
 334           (message "You clicked somewhere weird.")))
 335       ))
 336
 337
 338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 339 ;;                                                                            ;;
 340 ;; Multiple Option Dialog                                                     ;;
 341 ;;                                                                            ;;
 342 ;; Contributed by Philip Lord.                                                ;;
 343 ;;                                                                            ;;
 344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 345 (defclass efc-multi-option-dialog (efc-option-dialog)
 346   ((build-message :initarg :text
 347                   :type string
 348                   :initform "Building Dialog"
 349                   :documentation
 350                   "Warning message while building dialog, as this can be slow"))
 351   "Provides a dialog with several sets of OPTIONS.
 352 The dialog sets SELECTION to the options selected by the user.")
 353
 354 (defmethod initialize-instance ((this efc-multi-option-dialog) &rest fields)
 355   "Dialog constructor."
 356   (call-next-method))
 357
 358 (defmethod efc-dialog-create ((this efc-multi-option-dialog))
 359   (message "%s..." (oref this build-message))
 360   (widget-insert (oref this text))
 361   (widget-insert "\n\n")
 362   ;; use radio buttons slot as list of radio buttons rather than.
 363   (oset this radio-buttons
 364         (mapcar
 365          (lambda(list)
 366            (prog1
 367                (widget-create
 368                 (list
 369                  'radio-button-choice
 370                  :value
 371                  (efc-multi-option-dialog-default this list)
 372                  :args (mapcar
 373                         (lambda (x)
 374                           (list 'item x))
 375                         list)))
 376              (widget-insert "\n")))
 377          (efc-multi-option-dialog-sort this
 378                                        (oref this options))))
 379   (widget-insert "\n")
 380   (message "%s...done" (oref this text)))
 381
 382 (defmethod efc-dialog-ok((this efc-multi-option-dialog))
 383   ;; set the selection up as a list rather a simple result
 384   (oset this selection
 385         (mapcar
 386          (lambda(widget)
 387            (widget-value widget))
 388          (oref this radio-buttons)))
 389   (delete-window)
 390   (set-buffer (oref this initbuf))
 391   (pop-to-buffer (oref this initbuf))
 392   (kill-buffer (oref this buf))
 393   (exit-recursive-edit))
 394
 395
 396 (defmethod efc-multi-option-dialog-default ((this efc-multi-option-dialog) list)
 397   "Pick the default from a collection of options."
 398   (if (= 1 (length list))
 399       (car list)))
 400
 401 (defmethod efc-multi-option-dialog-sort ((this efc-multi-option-dialog) list)
 402   "Sort the options."
 403   ;; sort the ones with the most options first...
 404   (sort list
 405         (lambda(a b)
 406           (> (length a)
 407              (length b)))))
 408
 409
 410 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 411 ;;                                                                            ;;
 412 ;; Compiler Class                                                             ;;
 413 ;;                                                                            ;;
 414 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 415
 416 (defclass efc-compiler ()
 417   ((name             :initarg :name
 418                      :type string
 419                      :documentation "Compiler name.")
 420    (buffer           :initarg :buffer
 421                      :type buffer
 422                      :documentation
 423                      "Compilation buffer")
 424    (window           :initarg :window
 425                      :type window
 426                      :documentation
 427                      "Window that displays the compilation buffer.")
 428    (exec-path        :initarg :exec-path
 429                      :type string
 430                      :documentation "Path of compiler executable.")
 431    (comp-finish-fcn  :initarg :comp-finish-fcn
 432                      :type function
 433                      :documentation "Function to invoke at end of compilation."))
 434   "Class of compiler-like applications.")
 435
 436 (defmethod create-buffer ((this efc-compiler))
 437   "Create a buffer to display the output of a compiler process."
 438   (save-excursion
 439     (let ((buf (get-buffer-create (format "*%s*" (oref this name))))
 440           (error-regexp-alist compilation-error-regexp-alist)
 441           (enter-regexp-alist (if (boundp 'compilation-enter-directory-regexp-alist)
 442                                   compilation-enter-directory-regexp-alist))
 443           (leave-regexp-alist (if (boundp 'compilation-leave-directory-regexp-alist)
 444                                   compilation-leave-directory-regexp-alist))
 445           (file-regexp-alist (if (boundp 'compilation-file-regexp-alist)
 446                                  compilation-file-regexp-alist))
 447           (nomessage-regexp-alist (if (not jde-xemacsp) compilation-nomessage-regexp-alist))
 448           (parser compilation-parse-errors-function)
 449           (error-message "No further errors")
 450           (thisdir default-directory))
 451
 452       (oset this :buffer buf)
 453
 454       (set-buffer buf)
 455
 456       ;; Make sure a compiler process is not
 457       ;; already running.
 458       (let ((compiler-proc (get-buffer-process (current-buffer))))
 459         (if compiler-proc
 460             (if (or (not (eq (process-status compiler-proc) 'run))
 461                     (yes-or-no-p
 462                          (format "A %s process is running; kill it?" (oref this name))))
 463                 (condition-case ()
 464                     (progn
 465                       (interrupt-process compiler-proc)
 466                       (sit-for 1)
 467                       (delete-process compiler-proc))
 468                   (error nil))
 469               (error "Cannot have two processes in `%s' at once"
 470                          (buffer-name)))))
 471
 472       ;; In case the compiler buffer is current, make sure we get the global
 473       ;; values of compilation-error-regexp-alist, etc.
 474       (kill-all-local-variables)
 475
 476       ;; Clear out the compilation buffer and make it writable.
 477       (setq buffer-read-only nil)
 478       (buffer-disable-undo (current-buffer))
 479       (erase-buffer)
 480       (buffer-enable-undo (current-buffer))
 481
 482       (compilation-mode (oref this name))
 483
 484       (set (make-local-variable 'compilation-parse-errors-function) parser)
 485       (set (make-local-variable 'compilation-error-message) error-message)
 486       (set (make-local-variable 'compilation-error-regexp-alist)
 487              error-regexp-alist)
 488       (if (not jde-xemacsp)
 489           (progn
 490             (set (make-local-variable 'compilation-enter-directory-regexp-alist)
 491                  enter-regexp-alist)
 492             (set (make-local-variable 'compilation-leave-directory-regexp-alist)
 493                  leave-regexp-alist)
 494             (set (make-local-variable 'compilation-file-regexp-alist)
 495                  file-regexp-alist)
 496             (set (make-local-variable 'compilation-nomessage-regexp-alist)
 497               nomessage-regexp-alist)))
 498
 499       (if (slot-boundp this 'comp-finish-fcn)
 500           (set (make-local-variable 'compilation-finish-function)
 501                (oref this comp-finish-fcn)))
 502
 503       (setq default-directory thisdir
 504             compilation-directory-stack (list default-directory)))))
 505
 506 (defmethod get-args ((this efc-compiler))
 507   "Get a list of command-line arguments to pass to the
 508 compiler process.")
 509
 510
 511 (defmethod exec ((this efc-compiler))
 512   "Start the compiler process."
 513
 514   (create-buffer this)
 515
 516   ;; Pop to checker buffer.
 517   (let ((outwin (display-buffer (oref this :buffer))))
 518     (compilation-set-window-height outwin)
 519     (oset this :window outwin))
 520
 521   (if (not (featurep 'xemacs))
 522       (if compilation-process-setup-function
 523           (funcall compilation-process-setup-function)))
 524
 525   (let* ((outbuf (oref this :buffer))
 526          (executable-path (oref this exec-path))
 527          (args (get-args this)))
 528
 529     (save-excursion
 530       (set-buffer outbuf)
 531
 532       (insert (format "cd %s\n" default-directory))
 533
 534       (insert (concat
 535                executable-path
 536                " "
 537                (mapconcat 'identity args " ")
 538                "\n\n"))
 539
 540       (let* ((process-environment (cons "EMACS=t" process-environment))
 541              (w32-quote-process-args ?\")
 542              (win32-quote-process-args ?\") ;; XEmacs
 543              (proc (apply 'start-process
 544                           (downcase mode-name)
 545                           outbuf
 546                           executable-path
 547                           args)))
 548         (set-process-sentinel proc 'compilation-sentinel)
 549         (set-process-filter proc 'compilation-filter)
 550         (set-marker (process-mark proc) (point) outbuf)
 551         (setq compilation-in-progress
 552               (cons proc compilation-in-progress)))
 553
 554       (set-buffer-modified-p nil)
 555       (setq compilation-last-buffer (oref this :buffer)))))
 556
 557
 558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 559 ;;                                                                            ;;
 560 ;; Collection Class                                                           ;;
 561 ;;                                                                            ;;
 562 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 563
 564 (defclass efc-collection ()
 565   ((elem-type :initarg :elem-type
 566               :type (or null symbol)
 567               :initform nil
 568               :documentation "Type of element that this collection contains."))
 569   "A collection of objects. The collection can be either homogeneous, i.e.,
 570 composed of elements of one type, or heterogeneous. The ELEM-TYPE property of
 571 a heterogeneous collection is nil.")
 572
 573 (defmethod efc-coll-type-compatible-p ((this efc-collection) item)
 574   "Returns t if ITEM is type-compatible with this collection. An item is
 575 type-compatible with a collection if the collection is heterogeneous or
 576 the item's type is the same as the collection's element type."
 577   (let ((element-type (oref this elem-type)))
 578     (or (eq element-type nil)
 579         (typep item element-type))))
 580
 581 (defmethod efc-coll-iterator ((this efc-collection))
 582   "Returns an iterator for this collection."
 583   (error "Abstract method."))
 584
 585 (defmethod efc-coll-visit ((this efc-collection) visitor)
 586   "Maps VISITOR to each element of the collection. VISITOR
 587 is an object of efc-visitor class."
 588   (let ((iter (efc-coll-iterator this)))
 589     (while (efc-iter-has-next iter)
 590       (efc-visitor-visit visitor (efc-iter-next iter)))))
 591
 592 (defmethod efc-coll-memberp ((this efc-collection) member)
 593   "Returns nonil if this contains item."
 594   (error "Abstract method."))
 595
 596 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 597 ;;                                                                            ;;
 598 ;; Iterator Class                                                             ;;
 599 ;;                                                                            ;;
 600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 601
 602 (defclass efc-iterator ()
 603   ()
 604   "Iterates over a collection.")
 605
 606 (defmethod efc-iter-has-next ((this efc-iterator))
 607   "Returns nonnil if the iterator has not returned all of the collection's elements."
 608   (error "Abstract method."))
 609
 610 (defmethod efc-iter-next ((this efc-iterator))
 611   "Return the next element of the collection."
 612   (error "Abstract method."))
 613
 614
 615 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 616 ;;                                                                            ;;
 617 ;; Visitor Class                                                              ;;
 618 ;;                                                                            ;;
 619 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 620 (defclass efc-visitor ()
 621   ()
 622   "Visits each member of a collection.")
 623
 624 (defmethod efc-visitor-visit ((this efc-visitor) member)
 625   "Visits MEMBER, a member of a collection."
 626   (error "Abstract method."))
 627
 628
 629 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 630 ;;                                                                            ;;
 631 ;; List Class                                                                 ;;
 632 ;;                                                                            ;;
 633 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 634
 635 (defclass efc-list (efc-collection)
 636   ((items  :initarg :items
 637            :type list
 638            :initform nil
 639            :documentation "List of items."))
 640   "List of items.")
 641
 642 (defmethod initialize-instance ((this efc-list) &rest fields)
 643   "Iterator constructor."
 644   (call-next-method))
 645
 646 (defmethod efc-coll-add ((this efc-list) item)
 647   "Adds an item to the list."
 648   (if (efc-coll-type-compatible-p this item)
 649       (oset this items (append (oref this items) (list item)))
 650     (error "Tried to add an item of type %s to a list of items of type %s"
 651            (type-of item) (oref this elem-type))))
 652
 653 (defmethod efc-coll-iterator ((this efc-list))
 654   "Return an iterator for this list."
 655   (efc-list-iterator "list iterator" :list-obj this))
 656
 657
 658 (defmethod efc-coll-memberp ((this efc-list) item)
 659   "Returns nonil if this list contains item."
 660   (member item (oref this items)))
 661
 662 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 663 ;;                                                                            ;;
 664 ;; List Iterator Class                                                        ;;
 665 ;;                                                                            ;;
 666 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 667
 668 (defclass efc-list-iterator (efc-iterator)
 669   ((list-obj :initarg :list-obj
 670              :type efc-list
 671              :documentation "List that this iterator iterates.")
 672    (list     :type list
 673              :documentation "Lisp list."))
 674   "Iterates over a list.")
 675
 676 (defmethod initialize-instance ((this efc-list-iterator) &rest fields)
 677   "Iterator constructor."
 678   (call-next-method)
 679   (assert (oref this list-obj))
 680   (assert (typep (oref this list-obj) efc-list))
 681   (oset this list (oref (oref this list-obj) items)))
 682
 683 (defmethod efc-iter-has-next ((this efc-list-iterator))
 684   "Returns true if this iterator has another list item to return."
 685   (oref this list))
 686
 687 (defmethod efc-iter-next ((this efc-list-iterator))
 688   "Get next item in the list."
 689   (let* ((list (oref this list))
 690          (next (car list)))
 691     (oset this list (cdr list))
 692     next))
 693
 694
 695 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 696 ;;                                                                            ;;
 697 ;; List Set Class                                                             ;;
 698 ;;                                                                            ;;
 699 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 700 (defclass efc-list-set (efc-list)
 701   ()
 702   "List that contains no duplicates.")
 703
 704
 705 (defmethod efc-coll-add ((this efc-list-set) item)
 706   "Adds an item to a set only if the set does not
 707 already contain the item."
 708   (if (efc-coll-memberp this item)
 709       (error "This set already contains %s" item)
 710     (call-next-method)))
 711
 712
 713
 714 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 715 ;;                                                                            ;;
 716 ;; Association Class                                                          ;;
 717 ;;                                                                            ;;
 718 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 719 (defclass efc-assoc (efc-list)
 720   ()
 721   "Association")
 722
 723 (defmethod efc-coll-put ((this efc-assoc) key value)
 724   "Put an item into the association list."
 725   (oset this items (append (oref this items) (list (cons key value)))))
 726
 727 (defmethod efc-coll-get ((this efc-assoc) key)
 728   "Get an item from the association list."
 729   (cdr (assq  key (oref this items))))
 730
 731
 732 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 733 ;;                                                                            ;;
 734 ;; Association Set Class                                                      ;;
 735 ;;                                                                            ;;
 736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 737 (defclass efc-assoc-set (efc-assoc)
 738   ()
 739   "Association that contains no duplicate keys.")
 740
 741 (defmethod efc-coll-put ((this efc-assoc-set) key value)
 742   "Adds an item to a set only if the set does not
 743 already contain the item."
 744   (if (efc-coll-get this key)
 745       (error "This set already contains %s" key)
 746     (call-next-method)))
 747
 748
 749 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 750 ;;                                                                            ;;
 751 ;; Hash Table Class                                                           ;;
 752 ;;                                                                            ;;
 753 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 754 (defclass efc-hash-table (efc-collection)
 755   ((table :type hash-table
 756           :documentation "Lisp table object."))
 757   "Hash table.")
 758
 759
 760 (defmethod initialize-instance ((this efc-hash-table) &rest fields)
 761   "Hash table constructor."
 762   (call-next-method)
 763   (oset this table (make-hash-table)))
 764
 765 (defmethod efc-coll-put ((this efc-hash-table) key value)
 766   "Put an item into the table."
 767   (if (efc-coll-type-compatible-p this value)
 768       (puthash key value (oref this table))
 769     (error "Tried to add an item of type %s to a hash table of items of type %s"
 770            (type-of value) (oref this elem-type))))
 771
 772 (defmethod efc-coll-get ((this efc-hash-table) key)
 773   "Get an item from the table."
 774   (gethash key (oref this table)))
 775
 776 (defmethod efc-coll-visit ((this efc-hash-table) visitor)
 777   "Visit each item in the hash table. VISITOR is an instance
 778 of efc-visitor class."
 779   (maphash
 780    (lambda (key value)
 781      (efc-visitor-visit visitor value))
 782    (oref this table)))
 783
 784 (defmethod efc-coll-iterator ((this efc-hash-table))
 785   "Return an iterator for this hash table."
 786   (efc-list-iterator
 787    "hash table iterator"
 788    :list-obj (let (values)
 789                (maphash
 790                 (lambda (key value)
 791                   (setq values (append values (list value))))
 792                 (oref this table))
 793                values)))
 794
 795
 796
 797 (provide 'efc)
 798
 799
 800 ;; Change History
 801 ;; $Log: efc.el,v $
 802 ;; Revision 1.18  2005/03/19 03:50:31  paulk
 803 ;; Define an association set.
 804 ;;
 805 ;; Revision 1.17  2005/03/18 04:53:14  paulk
 806 ;; Define a set of collection classes.
 807 ;;
 808 ;; Revision 1.16  2004/12/10 03:38:04  paulk
 809 ;; Fix efc-compiler to make and set a buffer-local version of compilation-finish-function.
 810 ;; Thanks To David Evers.
 811 ;;
 812 ;; Revision 1.15  2004/07/01 14:04:39  jslopez
 813 ;; Compatibility fix for emacs in CVS. Replaces jde-xemacsp check for boundp for
 814 ;; the following variables: compilation-nomessage-regexp-alist,
 815 ;; compilation-file-regexp-alist, compilation-leave-directory-regexp-alist,
 816 ;; compilation-enter-directory-regexp-alist. Uses the compilation-mode without a
 817 ;; parameter. The emacs in CVS does not contain the variables, or the parameter
 818 ;; for compilation mode.
 819 ;;
 820 ;; Revision 1.14  2004/03/16 07:42:09  paulk
 821 ;; Define new efc-multi-option-dialog. Thanks to Philip Lord.
 822 ;;
 823 ;; Revision 1.13  2003/11/29 05:50:18  paulk
 824 ;; The efc-dialog-show method ofr efc-option-dialog now uses save-window-excursion
 825 ;; to restore the user's original window conversion after showing the selection
 826 ;; buffer.
 827 ;;
 828 ;; Revision 1.12  2003/08/25 04:57:30  paulk
 829 ;; Adds efc-compiler class. This class implements an Emacs interface to an external process
 830 ;; that generates compiler-like output.
 831 ;;
 832 ;; Revision 1.11  2003/06/07 04:04:10  paulk
 833 ;; Fix regexp for matching Emacs versions. Thanks to David Ponce.
 834 ;;
 835 ;; Revision 1.10  2003/03/28 05:33:29  andyp
 836 ;; XEmacs optimizations for JDEbug and efc.
 837 ;;
 838 ;; Revision 1.9  2002/03/29 12:40:27  paulk
 839 ;; Adds efc-query-option function.
 840 ;;
 841 ;; Revision 1.8  2002/03/19 12:24:47  paulk
 842 ;; Updated live-window error patch to work for Emacs 21.2.
 843 ;;
 844 ;; Revision 1.7  2002/02/21 05:35:39  paulk
 845 ;; efc-dialog class now creates the dialog buffer in
 846 ;; the efc-dialog-show method instead of in the
 847 ;; intialize-instance method. This permits reuse
 848 ;; of the dialog buffer object and hence persistance
 849 ;; of user settings in the dialog.
 850 ;;
 851 ;; Revision 1.6  2002/01/25 10:41:55  paulk
 852 ;; Fixes Lisp error: (wrong-type-argument window-live-p #<window 66>) that
 853 ;; occurs in Emacs 21.1.1 when the user clicks an efc dialog box button.
 854 ;;
 855 ;; Revision 1.5  2002/01/06 06:54:06  paulk
 856 ;; Finally found a fix for the efc dialog class that works around
 857 ;; the delete-other-windows bug in Emacs 21.
 858 ;;
 859 ;; Revision 1.4  2001/12/04 14:45:55  jslopez
 860 ;; Change jde-xemacs for (featurep 'xemacs).
 861 ;;
 862 ;; Revision 1.3  2001/12/04 12:32:34  jslopez
 863 ;; Fixes typo (efc-xemacsp to jde-xemacsp).
 864 ;;
 865 ;; Revision 1.2  2001/12/04 06:06:34  paulk
 866 ;; Remove carriage returns.
 867 ;;
 868 ;; Revision 1.1  2001/12/04 05:23:20  paulk
 869 ;; Initial revision.
 870 ;;
 871 ;;
 872
 873 ;; End of efc.el