Changeset 7844


Ignore:
Timestamp:
Dec 7, 2007, 7:04:37 PM (13 years ago)
Author:
gz
Message:

isearch, more cleanup, removing unused/supported stuff, redirect
standard output to listener during hemlock execution, start
formulating a hemlock support API in hemlock-ext package.

Location:
branches/event-ide/ccl/cocoa-ide
Files:
1 added
35 edited
2 moved

Legend:

Unmodified
Added
Removed
  • branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

    r7833 r7844  
    154154;;; Define some key event modifiers.
    155155
    156 ;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
    157 ;;; it to map NSEvent modifier keys to key-event modifiers.
    158 
    159 (hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
    160 (hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
    161 (hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
    162 (hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
     156(hemlock-ext:define-modifier-bit #$NSShiftKeyMask "Shift")
     157(hemlock-ext:define-modifier-bit #$NSControlKeyMask "Control")
     158(hemlock-ext:define-modifier-bit #$NSAlternateKeyMask "Meta")
     159(hemlock-ext:define-modifier-bit #$NSAlphaShiftKeyMask "Lock")
    163160
    164161
     
    784781          (when (eq buffer hi::*current-buffer*)
    785782            (setf hi::*current-buffer* nil))
    786           (hi::delete-buffer buffer :force t))))))
     783          (hi::delete-buffer buffer))))))
    787784
    788785
     
    861858  (with-autorelease-pool
    862859   (call-next-method)))
     860
     861(defconstant +shift-event-mask+ (hemlock-ext:key-event-modifier-mask "Shift"))
    863862
    864863;;; Translate a keyDown NSEvent to a Hemlock key-event.
     
    887886            (let* ((char (code-char c)))
    888887              (when (and char (standard-char-p char))
    889                 (setq bits (logandc2 bits hi::+shift-event-mask+))))
     888                (setq bits (logandc2 bits +shift-event-mask+))))
    890889            (hemlock-ext:make-key-event c bits)))))))
    891890
     
    15161515  (:metaclass ns:+ns-object))
    15171516
    1518 ;;; Mark the pane's modeline as needing display.  This is called whenever
     1517;;; Mark the buffer's modeline as needing display.  This is called whenever
    15191518;;; "interesting" attributes of a buffer are changed.
    1520 
    1521 (defun hi::invalidate-modeline (pane)
    1522   (#/setNeedsDisplay: (text-pane-mode-line pane) t))
     1519(defun hemlock-ext:invalidate-modeline (buffer)
     1520  (let* ((doc (hi::buffer-document buffer)))
     1521    (when doc
     1522      (document-invalidate-modeline doc))))
    15231523
    15241524(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
     
    17021702  (declare (ignore buffer)))
    17031703
     1704(defmethod document-invalidate-modeline ((self echo-area-document))
     1705  nil)
     1706
    17041707(objc:defmethod (#/close :void) ((self echo-area-document))
    17051708  (let* ((ts (slot-value self 'textstorage)))
     
    17081711      (close-hemlock-textstorage ts))))
    17091712
    1710 (objc:defmethod (#/updateChangeCount: :void)
    1711     ((self echo-area-document)
    1712      (change :<NSD>ocument<C>hange<T>ype))
     1713(objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :<NSD>ocument<C>hange<T>ype))
    17131714  (declare (ignore change)))
    1714 
    1715 (objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document)))
    17161715
    17171716(defloadvar *hemlock-frame-count* 0)
     
    18541853        (#/performSelectorOnMainThread:withObject:waitUntilDone:
    18551854         frame (@selector #/runErrorSheet:) params t)
    1856         (unless (eq *current-process* *initial-process*)
     1855        (unless (eq *current-process* ccl::*initial-process*)
    18571856          (wait-on-semaphore semaphore))))))
    18581857
    1859 (defun hi::report-hemlock-error (condition)
    1860   (let ((pane (hi::current-window)))
     1858(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition)
     1859  (let ((pane (hi::hemlock-view-pane view)))
    18611860    (when (and pane (not (%null-ptr-p pane)))
    18621861      (report-condition-in-hemlock-frame condition (#/window pane)))))
     
    20172016  (assume-cocoa-thread) ;; see comment in #/editingInProgress
    20182017  (slot-value (slot-value document 'textstorage) 'edit-count))
    2019 
    2020 #|
    2021 (defun hi::document-set-point-position (document)
    2022   (declare (ignorable document))
    2023   #+debug
    2024   (#_NSLog #@"Document set point position called")
    2025   (let* ((textstorage (slot-value document 'textstorage)))
    2026     (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2027      textstorage (@selector #/updateHemlockSelection) +null-ptr+ t)))
    2028 |#
    20292018
    20302019(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
     
    21172106
    21182107
    2119 (defun hi::set-document-modified (document flag)
    2120   (unless flag
    2121     (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2122      document
    2123      (@selector #/documentChangeCleared)
    2124      +null-ptr+
    2125      t)))
    2126 
    2127 
    2128 (defmethod hi::document-panes ((document t))
    2129   )
    2130 
    2131 
    2132 
    2133    
     2108(defun hemlock-ext:note-buffer-saved (buffer)
     2109  (assume-cocoa-thread)
     2110  (let* ((document (buffer-document buffer)))
     2111    (when document
     2112      ;; Hmm... I guess this is always done by the act of saving.
     2113      nil)))
     2114
     2115(defun hemlock-ext:note-buffer-unsaved (buffer)
     2116  (assume-cocoa-thread)
     2117  (let* ((document (buffer-document buffer)))
     2118    (when document
     2119      (#/updateChangeCount: document #$NSChangeCleared))))
     2120
    21342121
    21352122(defun size-of-char-in-font (f)
     
    22192206  (:metaclass ns:+ns-object))
    22202207
    2221 (objc:defmethod (#/documentChangeCleared :void) ((self hemlock-editor-document))
    2222   (#/updateChangeCount: self #$NSChangeCleared))
    2223 
    22242208(defmethod assume-not-editing ((doc hemlock-editor-document))
    22252209  (assume-not-editing (slot-value doc 'textstorage)))
     2210
     2211(defmethod document-invalidate-modeline ((self hemlock-editor-document))
     2212  (for-each-textview-using-storage
     2213   (slot-value self 'textstorage)
     2214   #'(lambda (tv)
     2215       (let* ((pane (text-view-pane tv)))
     2216         (unless (%null-ptr-p pane)
     2217           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
    22262218
    22272219(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
     
    22362228          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
    22372229
    2238 (defun hi::document-note-selection-set-by-search (doc)
    2239   (with-slots (textstorage) doc
    2240     (when textstorage
    2241       (with-slots (selection-set-by-search) textstorage
    2242         (setq selection-set-by-search #$YES)))))
     2230(defun hemlock-ext:note-selection-set-by-search (buffer)
     2231  (let* ((doc (hi::buffer-document buffer)))
     2232    (when doc
     2233      (with-slots (textstorage) doc
     2234        (when textstorage
     2235          (with-slots (selection-set-by-search) textstorage
     2236            (setq selection-set-by-search #$YES)))))))
    22432237
    22442238(objc:defmethod (#/validateMenuItem: :<BOOL>)
     
    23342328    (#/updateMirror textstorage)
    23352329    (#/endEditing textstorage)
    2336     (hi::document-set-point-position self)
     2330    (#/updateHemlockSelection textstorage)
    23372331    (setf (hi::buffer-modified buffer) nil)
    2338     (hi::queue-buffer-change buffer)
     2332    (hi::note-modeline-change buffer)
    23392333    t))
    23402334
     
    23952389               (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
    23962390
    2397           (hi::queue-buffer-change buffer)
    23982391          (#/beginEditing textstorage)
    23992392
     
    24102403           0
    24112404           (hemlock-buffer-length buffer))
     2405
     2406          (hi::note-modeline-change buffer)
    24122407
    24132408          (#/endEditing textstorage))
     
    24582453        (when cache (buffer-cache-buffer cache))))))
    24592454
    2460 (defmethod hi::window-buffer ((frame hemlock-frame))
     2455(defmethod hemlock-buffer ((frame hemlock-frame))
    24612456  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    24622457         (doc (#/documentForWindow: dc frame)))
     
    24672462      (hemlock-document-buffer doc))))
    24682463
    2469 (defmethod hi::window-buffer ((pane text-pane))
    2470   (hi::window-buffer (#/window pane)))
    2471 
    2472 (defun ordered-hemlock-windows ()
    2473   (delete-if-not #'(lambda (win)
    2474                      (and (typep win 'hemlock-frame)
    2475                           (hi::window-buffer win)))
    2476                    (windows)))
     2464(defmethod hemlock-buffer ((pane text-pane))
     2465  (hemlock-buffer (#/window pane)))
     2466
     2467(defmethod hemlock-buffer (whatever)
     2468  (let ((view (hi::hemlock-view whatever)))
     2469    (when view (hi::hemlock-view-buffer view))))
     2470
     2471(defun hemlock-ext:visible-buffers ()
     2472  "List of all buffers visible in windows, in z-order, frontmost first"
     2473  (loop for win in (windows)
     2474    as buf = (and (typep win 'hemlock-frame) (hemlock-buffer win))
     2475    when buf collect buf))
    24772476
    24782477(defmethod hi::document-panes ((document hemlock-editor-document))
     
    24912490  (with-slots (encoding) self
    24922491    (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
    2493     ;; Force modeline update.
    2494     (hi::queue-buffer-change (hemlock-document-buffer self))))
     2492    (hi::note-modeline-change (hemlock-document-buffer self))))
    24952493
    24962494(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
     
    26302628              (pref char-range :<NSR>ange.length)))))
    26312629   
    2632 (defun hi::scroll-window (textpane n)
     2630(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) n)
    26332631  (when n
    2634     (let* ((sv (text-pane-scroll-view textpane))
     2632    (let* ((textpane (hi::hemlock-view-pane view))
     2633           (sv (text-pane-scroll-view textpane))
    26352634           (tv (text-pane-text-view textpane))
    26362635           (char-height (text-view-char-height tv))
     
    26832682                      (hi::buffer-end point))))))))))
    26842683
    2685 
    2686 (defmethod hemlock::center-text-pane ((pane text-pane))
     2684(defmethod hemlock-ext:scroll-mark-to-top ((view hi:hemlock-view) mark)
     2685  "Make the position of MARK be on the first line displayed in the window"
     2686  (error "Not implemented yet"))
     2687
     2688
     2689(defmethod hemlock-ext:center-selection-in-view ((view hi:hemlock-view))
    26872690  (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2688    (text-pane-text-view pane)
     2691   (text-pane-text-view (hi::hemlock-view-pane view))
    26892692   (@selector #/centerSelectionInVisibleArea:)
    26902693   +null-ptr+
     
    28782881
    28792882
    2880 (defun hi::edit-definition (name)
    2881   (let* ((info (ccl::get-source-files-with-types&classes name)))
    2882     (when (null info)
    2883       (let* ((seen (list name))
    2884              (found ())
    2885              (pname (symbol-name name)))
    2886         (dolist (pkg (list-all-packages))
    2887           (let ((sym (find-symbol pname pkg)))
    2888             (when (and sym (not (member sym seen)))
    2889               (let ((new (ccl::get-source-files-with-types&classes sym)))
    2890                 (when new
    2891                   (setq info (append new info))
    2892                   (push sym found)))
    2893               (push sym seen))))
    2894         (when found
    2895           ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
    2896           (hi::loud-message "No definitions for ~s, using ~s instead"
    2897                             name (if (cdr found) found (car found))))))
    2898     (if info
    2899       (if (cdr info)
    2900         (edit-definition-list name info)
    2901         (edit-single-definition name (car info)))
    2902       (hi::editor-error "No known definitions for ~s" name))))
    2903 
    2904 
    29052883(defun find-definition-in-document (name indicator document)
    29062884  (let* ((buffer (hemlock-document-buffer document))
     
    29462924          (#/showWindows document))))))
    29472925
    2948 (defun edit-single-definition (name info)
     2926(defun hemlock-ext:edit-single-definition (name info)
    29492927  (let* ((request (make-instance 'cocoa-edit-definition-request
    29502928                                 :with-name (assign-id-map-id *edit-definition-id-map* name)
     
    29562934     t)))
    29572935
    2958                                        
    2959 (defun edit-definition-list (name infolist)
     2936
     2937(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
    29602938  (make-instance 'sequence-window-controller
    2961                  :sequence infolist
    2962                  :result-callback #'(lambda (info)
    2963                                       (edit-single-definition name info))
    2964                  :display #'(lambda (item stream)
    2965                               (prin1 (car item) stream))
    2966                  :title (format nil "Definitions of ~s" name)))
    2967 
    2968                                        
     2939    :title title
     2940    :sequence sequence
     2941    :result-callback action
     2942    :display printer))
     2943
    29692944(objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
    29702945                                                    type)
     
    30423017                  t)))))
    30433018          ((ccl::valid-function-name-p arg)
    3044            (hi::edit-definition arg))
     3019           (hemlock::edit-definition arg))
    30453020          (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p)))))
    30463021    t))
  • branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp

    r7833 r7844  
    2626
    2727(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
     28
     29(defun hemlock-ext:read-only-listener-p ()
     30  *read-only-listener*)
     31
    2832
    2933;;; Setup the server end of a pty pair.
     
    264268       (values nil t))))
    265269 
    266 (defun hi::top-listener-output-stream ()
     270(defun hemlock-ext:top-listener-output-stream ()
    267271  (let* ((doc (#/topListener hemlock-listener-document)))
    268272    (unless (%null-ptr-p doc)
     
    290294              (hi::buffer-minor-mode buffer "Listener") t
    291295              (hi::buffer-name buffer) listener-name)
    292         (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
     296        (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
    293297    doc))
    294298
  • branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp

    r7833 r7844  
    5858                                            notification)
    5959  (declare (ignore notification))
     60  (#/setDataSource: (slot-value self 'table-view) +null-ptr+)
    6061  (#/autorelease self))
    6162
     
    214215
    215216(defun assume-cocoa-thread ()
    216   #+debug (assert (eq *current-process* *initial-process*)))
     217  #+debug (assert (eq *current-process* ccl::*initial-process*)))
    217218
    218219(defmethod assume-not-editing ((whatever t)))
  • branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp

    r7833 r7844  
    6464    "table"
    6565    "modeline"
    66     "linimage"
    6766    "pop-up-stream"
    68     "cursor"
    6967    "font"
    7068    "streams"
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

    r7833 r7844  
    129129;(bind-key "Next Window" #k"control-x o")
    130130;(bind-key "Previous Window" #k"control-x p")
    131 (bind-key "Split Window" #k"control-x 2")
     131;(bind-key "Split Window" #k"control-x 2")
    132132;(bind-key "New Window" #k"control-x control-n")
    133133;(bind-key "Delete Window" #k"control-x d")
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp

    r7833 r7844  
    4242  "If true make the buffer modified, if NIL unmodified."
    4343  (unless (bufferp buffer) (error "~S is not a buffer." buffer))
    44   (let* ((was-modified (buffer-modified buffer)))
     44  (let* ((was-modified (buffer-modified buffer))
     45         (changed (not (eq was-modified (buffer-modified buffer)))))
    4546    (invoke-hook hemlock::buffer-modified-hook buffer sense)
    4647    (if sense
    4748      (setf (buffer-modified-tick buffer) (tick))
    4849      (setf (buffer-unmodified-tick buffer) (tick)))
    49     (unless (eq was-modified (buffer-modified buffer))
    50       (queue-buffer-change buffer)))
    51   (let* ((document (buffer-document buffer)))
    52     (if document (set-document-modified document sense)))
     50    (when changed
     51      (if sense
     52        (hemlock-ext:note-buffer-unsaved buffer)
     53        (hemlock-ext:note-buffer-saved buffer))
     54      (note-modeline-change buffer)))
    5355  sense)
    5456
     
    98100      ((null finfos) (nreverse result))))
    99101
    100 (defun %set-buffer-modeline-fields (buffer fields)
    101   (check-type fields list)
    102   (check-type buffer buffer "a Hemlock buffer")
    103   (sub-set-buffer-modeline-fields buffer fields)
    104   (dolist (w (buffer-windows buffer))
    105     (update-modeline-fields buffer w)))
    106 
    107 (defun sub-set-buffer-modeline-fields (buffer modeline-fields)
     102(defun set-buffer-modeline-fields (buffer modeline-fields)
    108103  (unless (every #'modeline-field-p modeline-fields)
    109104    (error "Fields must be a list of modeline-field objects."))
     
    499494    (warn "~s already exists, trying to delete" name *buffer-names*)
    500495    (let ((buffer (getstring name *buffer-names*)))
    501       (when (buffer-windows buffer)
    502         (delete-buffer buffer))))
     496      (delete-buffer buffer)))
    503497  (cond ((getstring name *buffer-names*)
    504498         nil)
     
    515509                         :bindings (make-hash-table)
    516510                         :point (copy-mark (region-end region))
    517                          :display-start (copy-mark (region-start region))
    518511                         :delete-hook delete-hook
    519512                         :variables (make-string-table))))
    520            (sub-set-buffer-modeline-fields buffer modeline-fields)
     513           (set-buffer-modeline-fields buffer modeline-fields)
    521514           (setf (line-%buffer (mark-line (region-start region))) buffer)
    522515           (push buffer *buffer-list*)
     
    529522           buffer))))
    530523
    531 (defun delete-buffer (buffer &key force)
    532   "Deletes a buffer.  If buffer is current, or if it is displayed in any
    533    windows, an error is signaled."
     524(defun delete-buffer (buffer)
     525  "Deletes a buffer.  If buffer is current, an error is signaled."
    534526  (when (eq buffer *current-buffer*)
    535527    (error "Cannot delete current buffer ~S." buffer))
    536   (unless force
    537     (when (buffer-windows buffer)
    538       (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
    539              buffer (length (buffer-windows buffer)))))
    540528  (invoke-hook (buffer-delete-hook buffer) buffer)
    541529  (invoke-hook hemlock::delete-buffer-hook buffer)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

    r7833 r7844  
    66
    77(in-package :hemlock-internals)
    8 
    9 (defun buffer-windows (buffer)
    10   (let* ((doc (buffer-document buffer)))
    11     (when doc
    12       (document-panes doc))))
    13 
    14 (defvar *window-list* ())
    15 
    16 (defun current-window ()
    17   "Return the current window.  The current window is specially treated by
    18   redisplay in several ways, the most important of which is that is does
    19   recentering, ensuring that the Buffer-Point of the current window's
    20   Window-Buffer is always displayed.  This may be set with Setf."
    21   (hemlock-view-pane *current-view*))
    22 
    23 (defun %set-current-window (new-window)
    24   #+not-yet
    25   (invoke-hook hemlock::set-window-hook new-window)
    26   (activate-hemlock-view new-window)
    27   (setf (hemlock-view-pane *current-view*) new-window))
    28 
    29 ;;; This is a public variable.
    30 ;;;
    31 
    32 (defun last-key-event-typed ()
    33   "This function returns the last key-event typed by the user and read as input."
    34   (hemlock-last-key-event-typed *current-view*))
    35 
    36 (defun %set-last-key-event-typed (key)
    37   (setf (hemlock-last-key-event-typed *current-view*) key))
    38 
    39 (defun hemlock::last-char-typed ()
    40   (let ((key (hemlock-last-key-event-typed *current-view*)))
    41     (when key (hemlock-ext:key-event-char key))))
    42 
    43 
    44 (defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
    45 
    46 (defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift"))
    47    
    48 (defun listen-editor-input (q)
    49   (ccl::with-locked-dll-header (q)
    50     (not (eq (ccl::dll-header-first q) q))))
    518
    529(defun add-buffer-font-region (buffer region)
     
    11875      (format t "~& style ~d ~d [~s]/ ~d [~s] ~a"
    11976              (font-mark-font start)
    120               (ccl::mark-absolute-position start)
     77              (gui::mark-absolute-position start)
    12178              (mark-%kind start)
    122               (ccl::mark-absolute-position end)
     79              (gui::mark-absolute-position end)
    12380              (mark-%kind end)
    12481              (eq r (buffer-active-font-region buffer))))))
     
    12885  (string-to-clipboard (region-to-string region)))
    12986
    130 ;;; Meta-.
    131 (defun hemlock::get-def-info-and-go-to-it (string package)
    132   (multiple-value-bind (fun-name error)
    133       (let* ((*package* package))
    134         (ignore-errors (values (read-from-string string))))
    135     (if error
    136       (editor-error)
    137       (hi::edit-definition fun-name))))
    138 
    139 ;;; Search highlighting
    140 (defun note-selection-set-by-search (&optional (buffer (current-buffer)))
    141   (let* ((doc (buffer-document buffer)))
    142     (when doc (hi::document-note-selection-set-by-search doc))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

    r7833 r7844  
    263263               (buffer-end point)
    264264               (when p (editor-error "No next line."))))))
    265     (unless (move-to-column point target) (line-end point))
     265    (unless (move-to-position point target) (line-end point))
    266266    (setf (last-command-type) :line-motion)))
    267267
     
    285285               (buffer-end point)
    286286               (when p (editor-error "No next line."))))))
    287     (unless (move-to-column point target) (line-end point))
     287    (unless (move-to-position point target) (line-end point))
    288288    (setf (last-command-type) :line-motion)))
    289289
     
    380380  :value nil)
    381381
    382 (defcommand "Scroll Window Down" (p &optional (window (current-window)))
     382(defcommand "Scroll Window Down" (p &optional (view (current-view)))
    383383  "Move down one screenfull.
    384384  With prefix argument scroll down that many lines."
     
    386386  window, down one screenfull.  If P is supplied then scroll that
    387387  many lines."
    388   (scroll-window window (or p :page-down)))
    389 
    390 (defcommand "Scroll Window Up" (p &optional (window (current-window)))
     388  (hemlock-ext:scroll-view view (or p :page-down)))
     389
     390(defcommand "Scroll Window Up" (p &optional (view (current-view)))
    391391  "Move up one screenfull.
    392392  With prefix argument scroll up that many lines."
     
    394394  window, up one screenfull.  If P is supplied then scroll that
    395395  many lines."
    396   (scroll-window window (if p (- p) :page-up)))
    397 
    398 (defcommand "Scroll Next Window Down" (p)
    399   "Do a \"Scroll Window Down\" on the next window."
    400   "Do a \"Scroll Window Down\" on the next window."
    401   (let ((win (next-window (current-window))))
    402     (when (eq win (current-window)) (editor-error "Only one window."))
    403     (scroll-window-down-command p win)))
    404 
    405 (defcommand "Scroll Next Window Up" (p)
    406   "Do a \"Scroll Window Up\" on the next window."
    407   "Do a \"Scroll Window Up\" on the next window."
    408   (let ((win (next-window (current-window))))
    409     (when (eq win (current-window)) (editor-error "Only one window."))
    410     (scroll-window-up-command p win)))
    411 
    412 
    413 
     396  (hemlock-ext:scroll-view view (if p (- p) :page-up)))
    414397
    415398;;;; Kind of miscellaneous commands:
    416399
    417 ;;; "Refresh Screen" may not be right with respect to wrapping lines in
    418 ;;; the case where an argument is supplied due the use of
    419 ;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter
    420 ;;; messed with point and did other hard to predict stuff.
    421 ;;;
    422400(defcommand "Refresh Screen" (p)
    423   "Refreshes everything in the window, centering current line."
    424   "Refreshes everything in the window, centering current line."
    425   (declare (ignore p))
    426   (center-text-pane (current-window)))
     401  "Refreshes everything in the window, centering current line.
     402With prefix argument, puts moves current line to top of window"
     403  (if p
     404    (hemlock-ext:scroll-mark-to-top (current-view) (current-point))
     405    (hemlock-ext:center-selection-in-view (current-view))))
    427406
    428407
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp

    r7833 r7844  
    5555             ,name)))
    5656
    57 (declfun window-buffer (window))
    5857(declfun change-to-buffer (buffer))     ;filecoms.lisp
    5958
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp

    r7833 r7844  
    4444    (#\m "Describe a mode."
    4545     (describe-mode-command nil))
    46     (#\p "Describe commands with mouse/pointer bindings."
    47     (describe-pointer-command nil))
     46    ;(#\p "Describe commands with mouse/pointer bindings."
     47    ; (describe-pointer-command nil))
    4848    (#\w "Find out Where a command is bound."
    4949     (where-is-command nil))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7833 r7844  
    3535;;; Message  --  Public
    3636;;;
    37 ;;;    Display the stuff on *echo-area-stream* and then wait.  Editor-Sleep
    38 ;;; will do a redisplay if appropriate.
     37;;;    Display the stuff on *echo-area-stream*
    3938;;;
    4039(defun message (string &rest args)
     
    158157           (display-prompt-nicely eps)
    159158           (modifying-buffer-storage (nil)
    160              (gui::event-loop #'(lambda () (eps-parse-results eps))))
     159             (with-standard-standard-output
     160              (gui::event-loop #'(lambda () (eps-parse-results eps)))))
    161161           #+gz (gui::log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
    162162       (setf (hemlock-prompted-input-state *current-view*) old-eps)
     
    494494                               ((:help *parse-help*) "Type Y or N."))
    495495  "Prompts for Y or N."
    496   (let ((old-window (current-window)))
    497     (unwind-protect
    498         (progn
    499           (setf (current-window) *echo-area-window*)
    500           (display-prompt-nicely prompt (or default-string
    501                                             (if defaultp (if default "Y" "N"))))
    502           (loop
    503             (let ((key-event (recursive-get-key-event *editor-input*)))
    504               (cond ((or (eq key-event #k"y")
    505                          (eq key-event #k"Y"))
    506                      (return t))
    507                     ((or (eq key-event #k"n")
    508                          (eq key-event #k"N"))
    509                      (return nil))
    510                     ((logical-key-event-p key-event :confirm)
    511                      (if defaultp
    512                          (return default)
    513                          (beep)))
    514                     ((logical-key-event-p key-event :help)
    515                      (hemlock::help-on-parse-command ()))
    516                     (t
    517                      (unless must-exist (return key-event))
    518                      (beep))))))
    519       (setf (current-window) old-window))))
     496  (with-echo-area-window
     497   (display-prompt-nicely prompt (or default-string
     498                                     (if defaultp (if default "Y" "N"))))
     499   (loop
     500     (let ((key-event (recursive-get-key-event *editor-input*)))
     501       (cond ((or (eq key-event #k"y")
     502                  (eq key-event #k"Y"))
     503              (return t))
     504             ((or (eq key-event #k"n")
     505                  (eq key-event #k"N"))
     506              (return nil))
     507             ((logical-key-event-p key-event :confirm)
     508              (if defaultp
     509                (return default)
     510                (beep)))
     511             ((logical-key-event-p key-event :help)
     512              (hemlock::help-on-parse-command ()))
     513             (t
     514              (unless must-exist (return key-event))
     515              (beep)))))))
    520516
    521517
     
    529525
    530526(defun prompt-for-key-event* (prompt change-window)
    531   (let ((old-window (current-window)))
    532     (unwind-protect
    533         (progn
    534           (when change-window
    535             (setf (current-window) *echo-area-window*))
    536           (display-prompt-nicely prompt)
    537           (recursive-get-key-event *editor-input* t))
    538       (when change-window (setf (current-window) old-window)))))
     527  (if change-window
     528    (with-echo-area-window
     529     (display-prompt-nicely prompt)
     530     (recursive-get-key-event *editor-input* t))
     531    (progn
     532     (display-prompt-nicely prompt)
     533     (recursive-get-key-event *editor-input* t))))
    539534
    540535(defun prompt-for-key (&key ((:must-exist must-exist) t)
     
    542537                            (prompt "Key: ")
    543538                            ((:help *parse-help*) "Type a key."))
    544   (let ((old-window (current-window))
    545         (string (if default
    546                     (or default-string
    547                         (let ((l (coerce default 'list)))
    548                           (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
    549 
    550     (unwind-protect
    551         (progn
    552           (setf (current-window) *echo-area-window*)
    553           (display-prompt-nicely prompt string)
    554           (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
    555                 (declare (vector key))
    556                 TOP
    557                 (setf key-event (recursive-get-key-event *editor-input*))
    558                 (cond ((logical-key-event-p key-event :quote)
    559                        (setf key-event (recursive-get-key-event *editor-input* t)))
    560                       ((logical-key-event-p key-event :confirm)
    561                        (cond ((and default (zerop (length key)))
    562                               (let ((res (get-command default :current)))
    563                                 (unless (commandp res) (go FLAME))
    564                                 (return (values default res))))
    565                              ((and (not must-exist) (plusp (length key)))
    566                               (return (copy-seq key)))
    567                              (t
    568                               (go FLAME))))
    569                       ((logical-key-event-p key-event :help)
    570                        (hemlock::help-on-parse-command ())
    571                        (go TOP)))
    572                 (vector-push-extend key-event key)       
    573                 (when must-exist
    574                   (let ((res (get-command key :current)))
    575                     (cond ((commandp res)
    576                            (hemlock-ext:print-pretty-key-event key-event
    577                                                        *echo-area-stream*
    578                                                        t)
    579                            (write-char #\space *echo-area-stream*)
    580                            (return (values (copy-seq key) res)))
    581                           ((not (eq res :prefix))
    582                            (vector-pop key)
    583                            (go FLAME)))))
    584                 (hemlock-ext:print-pretty-key key-event *echo-area-stream* t)
    585                 (write-char #\space *echo-area-stream*)
    586                 (go TOP)
    587                 FLAME
    588                 (beep)
    589                 (go TOP)))
    590       (force-output *echo-area-stream*)
    591       (setf (current-window) old-window))))
     539  (let ((string (if default
     540                  (or default-string
     541                      (let ((l (coerce default 'list)))
     542                        (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
     543    (with-echo-area-window
     544     (display-prompt-nicely prompt string)
     545     (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
     546           (declare (vector key))
     547           TOP
     548           (setf key-event (recursive-get-key-event *editor-input*))
     549           (cond ((logical-key-event-p key-event :quote)
     550                  (setf key-event (recursive-get-key-event *editor-input* t)))
     551                 ((logical-key-event-p key-event :confirm)
     552                  (cond ((and default (zerop (length key)))
     553                         (let ((res (get-command default :current)))
     554                           (unless (commandp res) (go FLAME))
     555                           (return (values default res))))
     556                        ((and (not must-exist) (plusp (length key)))
     557                         (return (copy-seq key)))
     558                        (t
     559                         (go FLAME))))
     560                 ((logical-key-event-p key-event :help)
     561                  (hemlock::help-on-parse-command ())
     562                  (go TOP)))
     563           (vector-push-extend key-event key)   
     564           (when must-exist
     565             (let ((res (get-command key :current)))
     566               (cond ((commandp res)
     567                      (hemlock-ext:print-pretty-key-event key-event
     568                                                          *echo-area-stream*
     569                                                          t)
     570                      (write-char #\space *echo-area-stream*)
     571                      (return (values (copy-seq key) res)))
     572                     ((not (eq res :prefix))
     573                      (vector-pop key)
     574                      (go FLAME)))))
     575           (hemlock-ext:print-pretty-key key-event *echo-area-stream* t)
     576           (write-char #\space *echo-area-stream*)
     577           (go TOP)
     578           FLAME
     579           (beep)
     580           (go TOP))
     581     (force-output *echo-area-stream*))))
    592582
    593583(defun prompt-for-command-key ()
    594   (let ((old-window (current-window)))
    595     (unwind-protect
    596         (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0)))
    597           (setf (current-window) hi::*echo-area-window*)
    598           (hi::display-prompt-nicely "Describe key: " nil)
    599           (loop
    600             (let ((key-event (get-key-event hi::*editor-input*)))
    601               (vector-push-extend key-event prompt-key)
    602               (let ((res (get-command prompt-key :current)))
    603                 (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
    604                 (write-char #\space *echo-area-stream*)
    605                 (unless (eq res :prefix)
    606                   (return (values (copy-seq prompt-key) res)))))))
    607       (setf (current-window) old-window))))
     584  (with-echo-area-window
     585   (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0)))
     586     (hi::display-prompt-nicely "Describe key: " nil)
     587     (loop
     588       (let ((key-event (get-key-event hi::*editor-input*)))
     589         (vector-push-extend key-event prompt-key)
     590         (let ((res (get-command prompt-key :current)))
     591           (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
     592           (write-char #\space *echo-area-stream*)
     593           (unless (eq res :prefix)
     594             (return (values (copy-seq prompt-key) res)))))))))
    608595
    609596
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

    r7833 r7844  
    9696          (cond (pns
    9797                 (write-line "Possible completions of what you have typed:" s)
    98                  (let ((width (- (window-width (current-window)) 27)))
     98                 (let ((width 55))
    9999                   (dolist (pn pns)
    100100                     (let* ((dir (directory-namestring pn))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

    r7833 r7844  
    697697
    698698
    699 
    700 
    701 
    702 
    703 
    704 
    705 
    706 
    707 
    708 
    709 
    710 
    711 
    712 
    713 
    714 
    715 
    716 
    717 
    718 
    719 
    720 
    721 
    722 
    723699(defun universal-time-to-string (ut)
    724700  (multiple-value-bind (sec min hour day month year)
     
    730706            (rem year 100)
    731707            hour min sec)))
    732 
    733 
    734 
    735 
    736 
    737 
    738 ;;;; Window hacking commands:
    739 
    740 
    741 
    742 (defcommand "Split Window" (p)
    743   "Make a new window by splitting the current window.
    744    The new window is made the current window and displays starting at
    745    the same place as the current window."
    746   "Create a new window which displays starting at the same place
    747    as the current window."
    748   (declare (ignore p))
    749   (let ((new (make-window (window-display-start (current-window)))))
    750     (unless new (editor-error "Could not make a new window."))
    751     (setf (current-window) new)))
    752 
    753 
    754 
    755 
    756 
    757 
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp

    r2096 r7844  
    504504                                          end-mark column)
    505505  (with-mark ((mark1 fill-mark :left-inserting))
    506     (move-to-column mark1 column)
     506    (move-to-position mark1 column)
    507507    (cond ((not (whitespace-attribute-p (next-character mark1)))
    508508           (if (not (find-attribute mark1 :whitespace))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/font.lisp

    r7595 r7844  
    1818
    1919(in-package :hemlock-internals)
    20 
    21 ;;; Default-font used to be in the above list, but when I cleaned up the way
    22 ;;; Hemlock compiles, a name conflict occurred because "Default Font" is a
    23 ;;; Hemlock variable.  It is now exported by the export list in rompsite.lisp.
    24 
    25 (defvar *default-font-family* (make-font-family))
    26 
    27 
    28 
    2920
    3021;;;; Creating, Deleting, and Moving.
     
    6455    (new-font-mark new line)
    6556    (push new (line-marks line))
    66     (incf (line-font-mark-count line))
    6757    new))
    6858
     
    7363    (when line
    7464      (setf (line-marks line) (delq font-mark (line-marks line)))
    75       (decf (line-font-mark-count line))
    7665      (nuke-font-mark font-mark line)
    7766      (setf (mark-line font-mark) nil))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp

    r7833 r7844  
    1212(defun skip-whitespace (&optional (stream *standard-input*))
    1313  (peek-char t stream))
    14 
    15 #+clx
    16 (defun disable-clx-event-handling (display)
    17   )
    18 
    19 (defun quit ()
    20   )
    21 
    22 (defun sap-ref-8 (vec index)
    23   (declare (ignore vec index))
    24   (error "SAP-REF-8 called.") )
    2514
    2615(defvar hi::*command-line-switches* nil)
     
    3726  with setf."
    3827  (truename #p""))
    39 
    40 ;;;;;;;;;;;;
    41 
    42 (defstruct (object-set (:constructor make-object-set (name &optional default-handler)))
    43   name
    44   default-handler
    45   (table (make-hash-table)))
    46 
    47 (defvar *xwindow-hash* (make-hash-table :test #'eq))
    48 
    49 (defun hi::add-xwindow-object (window object object-set)
    50   (setf (gethash window *xwindow-hash*) (list object object-set)))
    51 
    52 (defun hi::remove-xwindow-object (window)
    53   (remhash window *xwindow-hash*))
    54 
    55 (defun lisp--map-xwindow (window)
    56   ;; -> object object-set
    57   (values-list (gethash window *xwindow-hash*)))
    58 
    59 
    60 
    61 ;;;; Object set event handling.
    62 
    63 ;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear
    64 ;;; events on the display before signalling any errors.  This is necessary
    65 ;;; since reading on certain CMU Common Lisp streams involves SERVER, and
    66 ;;; getting an error while trying to handle an event causes repeated attempts
    67 ;;; to handle the same event.
    68 ;;;
    69 (defvar *process-clx-event-display* nil)
    70 
    71 (defvar *object-set-event-handler-print* nil)
    72 
    73 (declaim (declaration values))
    74 
    75 #+clx
    76 (defun object-set-event-handler (display &optional (timeout 0))
    77   "This display event handler uses object sets to map event windows cross
    78    event types to handlers.  It uses XLIB:EVENT-CASE to bind all the slots
    79    of each event, calling the handlers on all these values in addition to
    80    the event key and send-event-p.  Describe EXT:SERVE-MUMBLE, where mumble
    81    is an event keyword name for the exact order of arguments.
    82    :mapping-notify and :keymap-notify events are ignored since they do not
    83    occur on any particular window.  After calling a handler, each branch
    84    returns t to discard the event.  While the handler is executing, all
    85    errors go through a handler that flushes all the display's events and
    86    returns.  This prevents infinite errors since the debug and terminal
    87    streams loop over SYSTEM:SERVE-EVENT.  This function returns t if there
    88    were some event to handle, nil otherwise.  It returns immediately if
    89    there is no event to handle."
    90   (macrolet ((dispatch (event-key &rest args)
    91                `(multiple-value-bind (object object-set)
    92                  (lisp--map-xwindow event-window)
    93                  (unless object
    94                    (cond ((not (typep event-window 'xlib:window))
    95                           ;;(xlib:discard-current-event display)
    96                           (warn "Discarding ~S event on non-window ~S."
    97                                 ,event-key event-window)
    98                           (return-from object-set-event-handler nil)
    99                           )
    100                          (t
    101                           (flush-display-events display)
    102                           (error "~S not a known X window.~%~
    103                                    Received event ~S."
    104                                  event-window ,event-key))))
    105                  (handler-bind ((error #'(lambda (condx)
    106                                            (declare (ignore condx))
    107                                            (flush-display-events display))))
    108                    (when *object-set-event-handler-print*
    109                      (print ,event-key) (force-output))
    110                    (funcall (gethash ,event-key
    111                                      (object-set-table object-set)
    112                                      (object-set-default-handler
    113                                       object-set))
    114                             object ,event-key
    115                             ,@args))
    116                  (setf result t))))
    117     (let ((*process-clx-event-display* display)
    118           (result nil))
    119       (xlib:event-case (display :timeout timeout)
    120                        ((:key-press :key-release :button-press :button-release)
    121                         (event-key event-window root child same-screen-p
    122                                    x y root-x root-y state time code send-event-p)
    123                         (dispatch event-key event-window root child same-screen-p
    124                                   x y root-x root-y state time code send-event-p))
    125                        (:motion-notify (event-window root child same-screen-p
    126                                         x y root-x root-y state time hint-p send-event-p)
    127                         (dispatch :motion-notify event-window root child same-screen-p
    128                          x y root-x root-y state time hint-p send-event-p))
    129                        (:enter-notify (event-window root child same-screen-p
    130                                        x y root-x root-y state time mode kind send-event-p)
    131                         (dispatch :enter-notify event-window root child same-screen-p
    132                          x y root-x root-y state time mode kind send-event-p))
    133                        (:leave-notify (event-window root child same-screen-p
    134                                        x y root-x root-y state time mode kind send-event-p)
    135                         (dispatch :leave-notify event-window root child same-screen-p
    136                          x y root-x root-y state time mode kind send-event-p))
    137                        (:exposure (event-window x y width height count send-event-p)
    138                         (dispatch :exposure event-window x y width height count send-event-p))
    139                        (:graphics-exposure (event-window x y width height count major minor
    140                                             send-event-p)
    141                         (dispatch :graphics-exposure event-window x y width height
    142                          count major minor send-event-p))
    143                        (:no-exposure (event-window major minor send-event-p)
    144                         (dispatch :no-exposure event-window major minor send-event-p))
    145                        (:focus-in (event-window mode kind send-event-p)
    146                         (dispatch :focus-in event-window mode kind send-event-p))
    147                        (:focus-out (event-window mode kind send-event-p)
    148                         (dispatch :focus-out event-window mode kind send-event-p))
    149                        (:keymap-notify ()
    150                         (warn "Ignoring keymap notify event.")
    151                         (when *object-set-event-handler-print*
    152                           (print :keymap-notify) (force-output))
    153                         (setf result t))
    154                        (:visibility-notify (event-window state send-event-p)
    155                         (dispatch :visibility-notify event-window state send-event-p))
    156                        (:create-notify (event-window window x y width height border-width
    157                                         override-redirect-p send-event-p)
    158                         (dispatch :create-notify event-window window x y width height
    159                          border-width override-redirect-p send-event-p))
    160                        (:destroy-notify (event-window window send-event-p)
    161                         (dispatch :destroy-notify event-window window send-event-p))
    162                        (:unmap-notify (event-window window configure-p send-event-p)
    163                         (dispatch :unmap-notify event-window window configure-p send-event-p))
    164                        (:map-notify (event-window window override-redirect-p send-event-p)
    165                         (dispatch :map-notify event-window window override-redirect-p
    166                          send-event-p))
    167                        (:map-request (event-window window send-event-p)
    168                         (dispatch :map-request event-window window send-event-p))
    169                        (:reparent-notify (event-window window parent x y override-redirect-p
    170                                           send-event-p)
    171                         (dispatch :reparent-notify event-window window parent x y
    172                          override-redirect-p send-event-p))
    173                        (:configure-notify (event-window window x y width height border-width
    174                                            above-sibling override-redirect-p send-event-p)
    175                         (dispatch :configure-notify event-window window x y width height
    176                          border-width above-sibling override-redirect-p
    177                          send-event-p))
    178                        (:gravity-notify (event-window window x y send-event-p)
    179                         (dispatch :gravity-notify event-window window x y send-event-p))
    180                        (:resize-request (event-window width height send-event-p)
    181                         (dispatch :resize-request event-window width height send-event-p))
    182                        (:configure-request (event-window window x y width height border-width
    183                                             stack-mode above-sibling value-mask send-event-p)
    184                         (dispatch :configure-request event-window window x y width height
    185                          border-width stack-mode above-sibling value-mask
    186                          send-event-p))
    187                        (:circulate-notify (event-window window place send-event-p)
    188                         (dispatch :circulate-notify event-window window place send-event-p))
    189                        (:circulate-request (event-window window place send-event-p)
    190                         (dispatch :circulate-request event-window window place send-event-p))
    191                        (:property-notify (event-window atom state time send-event-p)
    192                         (dispatch :property-notify event-window atom state time send-event-p))
    193                        (:selection-clear (event-window selection time send-event-p)
    194                         (dispatch :selection-notify event-window selection time send-event-p))
    195                        (:selection-request (event-window requestor selection target property
    196                                             time send-event-p)
    197                         (dispatch :selection-request event-window requestor selection target
    198                          property time send-event-p))
    199                        (:selection-notify (event-window selection target property time
    200                                            send-event-p)
    201                         (dispatch :selection-notify event-window selection target property time
    202                          send-event-p))
    203                        (:colormap-notify (event-window colormap new-p installed-p send-event-p)
    204                         (dispatch :colormap-notify event-window colormap new-p installed-p
    205                          send-event-p))
    206                        (:mapping-notify (request)
    207                         (warn "Ignoring mapping notify event -- ~S." request)
    208                         (when *object-set-event-handler-print*
    209                           (print :mapping-notify) (force-output))
    210                         (setf result t))
    211                        (:client-message (event-window format data send-event-p)
    212                         (dispatch :client-message event-window format data send-event-p)))
    213       result)))
    214 
    215 #+clx
    216 (defun default-clx-event-handler (object event-key event-window &rest ignore)
    217   (declare (ignore ignore))
    218   (flush-display-events *process-clx-event-display*)
    219   (error "No handler for event type ~S on ~S in ~S."
    220          event-key object (lisp--map-xwindow event-window)))
    221 
    222 #+clx
    223 (defun flush-display-events (display)
    224   "Dumps all the events in display's event queue including the current one
    225    in case this is called from within XLIB:EVENT-CASE, etc."
    226   (xlib:discard-current-event display)
    227   (xlib:event-case (display :discard-p t :timeout 0)
    228     (t () nil)))
    229 
    230 #+clx
    231 (defmacro with-clx-event-handling ((display handler) &rest body)
    232   "Evaluates body in a context where events are handled for the display
    233    by calling handler on the display.  This destroys any previously established
    234    handler for display."
    235   `(unwind-protect
    236        (progn
    237          (enable-clx-event-handling ,display ,handler)
    238          ,@body)
    239      (disable-clx-event-handling ,display) ))
    240 
    241 #+clx
    242 (defun enable-clx-event-handling (display handler)
    243   nil)
    244 
    245 #+clx
    246 (defun disable-clx-event-handling (display)
    247   nil)
    248 
    249 #||
    250 ;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
    251 ;;; *display-event-handlers*.  It also uses SYSTEM:ADD-FD-HANDLER to have
    252 ;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
    253 ;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
    254 ;;; file descriptor, the file descriptor is also mapped to the display in
    255 ;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
    256 ;;;
    257 (defun enable-clx-event-handling (display handler)
    258   "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
    259    connection to the X11 server, handler is called on the display.  Handler
    260    is invoked in a dynamic context with an error handler bound that will
    261    flush all events from the display and return.  By returning, it declines
    262    to handle the error, but it will have cleared all events; thus, entering
    263    the debugger will not result in infinite errors due to streams that wait
    264    via SYSTEM:SERVE-EVENT for input.  Calling this repeatedly on the same
    265    display establishes handler as a new handler, replacing any previous one
    266    for display."
    267   (check-type display xlib:display)
    268   (let ((change-handler (assoc display *display-event-handlers*)))
    269     (if change-handler
    270         (setf (cdr change-handler) handler)
    271         (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
    272           (system:add-fd-handler fd :input #'call-display-event-handler)
    273           (setf (gethash fd *clx-fds-to-displays*) display)
    274           (push (cons display handler) *display-event-handlers*)))))
    275 
    276 ;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
    277 ;;; the display to its handler.  If we can't find the display, we remove the
    278 ;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
    279 ;;; display from *display-event-handlers*.  This is necessary to try to keep
    280 ;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
    281 ;;; over.  This is possible since many CMU Common Lisp streams loop over
    282 ;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
    283 ;;; possible.
    284 ;;;
    285 (defun call-display-event-handler (file-descriptor)
    286   (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
    287     (unless display
    288       (system:invalidate-descriptor file-descriptor)
    289       (setf *display-event-handlers*
    290             (delete file-descriptor *display-event-handlers*
    291                     :key #'(lambda (d/h)
    292                              (fd-stream-fd
    293                               (xlib::display-input-stream
    294                                (car d/h))))))
    295       (error "File descriptor ~S not associated with any CLX display.~%~
    296                 It has been removed from system:serve-event's knowledge."
    297              file-descriptor))
    298     (let ((handler (cdr (assoc display *display-event-handlers*))))
    299       (unless handler
    300         (flush-display-events display)
    301         (error "Display ~S not associated with any event handler." display))
    302       (handler-bind ((error #'(lambda (condx)
    303                                 (declare (ignore condx))
    304                                 (flush-display-events display))))
    305         (funcall handler display)))))
    306 
    307 (defun disable-clx-event-handling (display)
    308   "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
    309   (setf *display-event-handlers*
    310         (delete display *display-event-handlers* :key #'car))
    311   (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
    312     (remhash fd *clx-fds-to-displays*)
    313     (system:invalidate-descriptor fd)))
    314 ||#
    315 
    316 
    317 
    318 ;;;; Key and button service.
    319 
    320 (defun serve-key-press (object-set fun)
    321   "Associate a method in the object-set with :key-press events.  The method
    322    is called on the object the event occurred, event key, event window, root,
    323    child, same-screen-p, x, y, root-x, root-y, state, time, code, and
    324    send-event-p."
    325   (setf (gethash :key-press (object-set-table object-set)) fun))
    326 
    327 (defun serve-key-release (object-set fun)
    328   "Associate a method in the object-set with :key-release events.  The method
    329    is called on the object the event occurred, event key, event window, root,
    330    child, same-screen-p, x, y, root-x, root-y, state, time, code, and
    331    send-event-p."
    332   (setf (gethash :key-release (object-set-table object-set)) fun))
    333 
    334 (defun serve-button-press (object-set fun)
    335   "Associate a method in the object-set with :button-press events.  The method
    336    is called on the object the event occurred, event key, event window, root,
    337    child, same-screen-p, x, y, root-x, root-y, state, time, code, and
    338    send-event-p."
    339   (setf (gethash :button-press (object-set-table object-set)) fun))
    340 
    341 (defun serve-button-release (object-set fun)
    342   "Associate a method in the object-set with :button-release events.  The
    343    method is called on the object the event occurred, event key, event window,
    344    root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and
    345    send-event-p."
    346   (setf (gethash :button-release (object-set-table object-set)) fun))
    347 
    348 
    349 
    350 
    351 ;;;; Mouse service.
    352 
    353 (defun serve-motion-notify (object-set fun)
    354   "Associate a method in the object-set with :motion-notify events.  The method
    355    is called on the object the event occurred, event key, event window, root,
    356    child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and
    357    send-event-p."
    358   (setf (gethash :motion-notify (object-set-table object-set)) fun))
    359 
    360 (defun serve-enter-notify (object-set fun)
    361   "Associate a method in the object-set with :enter-notify events.  The method
    362    is called on the object the event occurred, event key, event window, root,
    363    child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
    364    and send-event-p."
    365   (setf (gethash :enter-notify (object-set-table object-set)) fun))
    366 
    367 (defun serve-leave-notify (object-set fun)
    368   "Associate a method in the object-set with :leave-notify events.  The method
    369    is called on the object the event occurred, event key, event window, root,
    370    child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
    371    and send-event-p."
    372   (setf (gethash :leave-notify (object-set-table object-set)) fun))
    373 
    374 
    375 
    376 
    377 ;;;; Keyboard service.
    378 
    379 (defun serve-focus-in (object-set fun)
    380   "Associate a method in the object-set with :focus-in events.  The method
    381    is called on the object the event occurred, event key, event window, mode,
    382    kind, and send-event-p."
    383   (setf (gethash :focus-in (object-set-table object-set)) fun))
    384 
    385 (defun serve-focus-out (object-set fun)
    386   "Associate a method in the object-set with :focus-out events.  The method
    387    is called on the object the event occurred, event key, event window, mode,
    388    kind, and send-event-p."
    389   (setf (gethash :focus-out (object-set-table object-set)) fun))
    390 
    391 
    392 
    393 
    394 ;;;; Exposure service.
    395 
    396 (defun serve-exposure (object-set fun)
    397   "Associate a method in the object-set with :exposure events.  The method
    398    is called on the object the event occurred, event key, event window, x, y,
    399    width, height, count, and send-event-p."
    400   (setf (gethash :exposure (object-set-table object-set)) fun))
    401 
    402 (defun serve-graphics-exposure (object-set fun)
    403   "Associate a method in the object-set with :graphics-exposure events.  The
    404    method is called on the object the event occurred, event key, event window,
    405    x, y, width, height, count, major, minor, and send-event-p."
    406   (setf (gethash :graphics-exposure (object-set-table object-set)) fun))
    407 
    408 (defun serve-no-exposure (object-set fun)
    409   "Associate a method in the object-set with :no-exposure events.  The method
    410    is called on the object the event occurred, event key, event window, major,
    411    minor, and send-event-p."
    412   (setf (gethash :no-exposure (object-set-table object-set)) fun))
    413  
    414 
    415 
    416 
    417 ;;;; Structure service.
    418 
    419 (defun serve-visibility-notify (object-set fun)
    420   "Associate a method in the object-set with :visibility-notify events.  The
    421    method is called on the object the event occurred, event key, event window,
    422    state, and send-event-p."
    423   (setf (gethash :visibility-notify (object-set-table object-set)) fun))
    424 
    425 (defun serve-create-notify (object-set fun)
    426   "Associate a method in the object-set with :create-notify events.  The
    427    method is called on the object the event occurred, event key, event window,
    428    window, x, y, width, height, border-width, override-redirect-p, and
    429    send-event-p."
    430   (setf (gethash :create-notify (object-set-table object-set)) fun))
    431 
    432 (defun serve-destroy-notify (object-set fun)
    433   "Associate a method in the object-set with :destroy-notify events.  The
    434    method is called on the object the event occurred, event key, event window,
    435    window, and send-event-p."
    436   (setf (gethash :destroy-notify (object-set-table object-set)) fun))
    437 
    438 (defun serve-unmap-notify (object-set fun)
    439   "Associate a method in the object-set with :unmap-notify events.  The
    440    method is called on the object the event occurred, event key, event window,
    441    window, configure-p, and send-event-p."
    442   (setf (gethash :unmap-notify (object-set-table object-set)) fun))
    443 
    444 (defun serve-map-notify (object-set fun)
    445   "Associate a method in the object-set with :map-notify events.  The
    446    method is called on the object the event occurred, event key, event window,
    447    window, override-redirect-p, and send-event-p."
    448   (setf (gethash :map-notify (object-set-table object-set)) fun))
    449 
    450 (defun serve-map-request (object-set fun)
    451   "Associate a method in the object-set with :map-request events.  The
    452    method is called on the object the event occurred, event key, event window,
    453    window, and send-event-p."
    454   (setf (gethash :map-request (object-set-table object-set)) fun))
    455 
    456 (defun serve-reparent-notify (object-set fun)
    457   "Associate a method in the object-set with :reparent-notify events.  The
    458    method is called on the object the event occurred, event key, event window,
    459    window, parent, x, y, override-redirect-p, and send-event-p."
    460   (setf (gethash :reparent-notify (object-set-table object-set)) fun))
    461 
    462 (defun serve-configure-notify (object-set fun)
    463   "Associate a method in the object-set with :configure-notify events.  The
    464    method is called on the object the event occurred, event key, event window,
    465    window, x, y, width, height, border-width, above-sibling,
    466    override-redirect-p, and send-event-p."
    467   (setf (gethash :configure-notify (object-set-table object-set)) fun))
    468 
    469 (defun serve-gravity-notify (object-set fun)
    470   "Associate a method in the object-set with :gravity-notify events.  The
    471    method is called on the object the event occurred, event key, event window,
    472    window, x, y, and send-event-p."
    473   (setf (gethash :gravity-notify (object-set-table object-set)) fun))
    474 
    475 (defun serve-resize-request (object-set fun)
    476   "Associate a method in the object-set with :resize-request events.  The
    477    method is called on the object the event occurred, event key, event window,
    478    width, height, and send-event-p."
    479   (setf (gethash :resize-request (object-set-table object-set)) fun))
    480 
    481 (defun serve-configure-request (object-set fun)
    482   "Associate a method in the object-set with :configure-request events.  The
    483    method is called on the object the event occurred, event key, event window,
    484    window, x, y, width, height, border-width, stack-mode, above-sibling,
    485    value-mask, and send-event-p."
    486   (setf (gethash :configure-request (object-set-table object-set)) fun))
    487 
    488 (defun serve-circulate-notify (object-set fun)
    489   "Associate a method in the object-set with :circulate-notify events.  The
    490    method is called on the object the event occurred, event key, event window,
    491    window, place, and send-event-p."
    492   (setf (gethash :circulate-notify (object-set-table object-set)) fun))
    493 
    494 (defun serve-circulate-request (object-set fun)
    495   "Associate a method in the object-set with :circulate-request events.  The
    496    method is called on the object the event occurred, event key, event window,
    497    window, place, and send-event-p."
    498   (setf (gethash :circulate-request (object-set-table object-set)) fun))
    499 
    500 
    501 
    502 
    503 ;;;; Misc. service.
    504 
    505 (defun serve-property-notify (object-set fun)
    506   "Associate a method in the object-set with :property-notify events.  The
    507    method is called on the object the event occurred, event key, event window,
    508    atom, state, time, and send-event-p."
    509   (setf (gethash :property-notify (object-set-table object-set)) fun))
    510 
    511 (defun serve-selection-clear (object-set fun)
    512   "Associate a method in the object-set with :selection-clear events.  The
    513    method is called on the object the event occurred, event key, event window,
    514    selection, time, and send-event-p."
    515   (setf (gethash :selection-clear (object-set-table object-set)) fun))
    516 
    517 (defun serve-selection-request (object-set fun)
    518   "Associate a method in the object-set with :selection-request events.  The
    519    method is called on the object the event occurred, event key, event window,
    520    requestor, selection, target, property, time, and send-event-p."
    521   (setf (gethash :selection-request (object-set-table object-set)) fun))
    522 
    523 (defun serve-selection-notify (object-set fun)
    524   "Associate a method in the object-set with :selection-notify events.  The
    525    method is called on the object the event occurred, event key, event window,
    526    selection, target, property, time, and send-event-p."
    527   (setf (gethash :selection-notify (object-set-table object-set)) fun))
    528 
    529 (defun serve-colormap-notify (object-set fun)
    530   "Associate a method in the object-set with :colormap-notify events.  The
    531    method is called on the object the event occurred, event key, event window,
    532    colormap, new-p, installed-p, and send-event-p."
    533   (setf (gethash :colormap-notify (object-set-table object-set)) fun))
    534 
    535 (defun serve-client-message (object-set fun)
    536   "Associate a method in the object-set with :client-message events.  The
    537    method is called on the object the event occurred, event key, event window,
    538    format, data, and send-event-p."
    539   (setf (gethash :client-message (object-set-table object-set)) fun))
    54028
    54129
     
    54836        do
    54937        (setf (aref dest d) (aref src s))))
    550 
    551 #+clx
    552 (defun serve-event (&optional timeout)
    553   (let ((dps))
    554     (maphash (lambda (win value)
    555                (pushnew (xlib:window-display win) dps))
    556              *xwindow-hash*)
    557     (when dps
    558       (object-set-event-handler (car dps) timeout))))
    559 
    560 #+CLISP
    561 (progn
    562 
    563   #-NIL
    564   (defun serve-event (&optional timeout)
    565     (hemlock.wire::serve-event timeout))
    566 
    567 ;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
    568 ;;; *display-event-handlers*.  It also uses SYSTEM:ADD-FD-HANDLER to have
    569 ;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
    570 ;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
    571 ;;; file descriptor, the file descriptor is also mapped to the display in
    572 ;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
    573 ;;;
    574 
    575   (defvar *display-event-handlers* nil)
    576 
    577   (defun enable-clx-event-handling (display handler)
    578     "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
    579    connection to the X11 server, handler is called on the display.  Handler
    580    is invoked in a dynamic context with an error handler bound that will
    581    flush all events from the display and return.  By returning, it declines
    582    to handle the error, but it will have cleared all events; thus, entering
    583    the debugger will not result in infinite errors due to streams that wait
    584    via SYSTEM:SERVE-EVENT for input.  Calling this repeatedly on the same
    585    display establishes handler as a new handler, replacing any previous one
    586    for display."
    587     (check-type display xlib:display)
    588     (let ((change-handler (assoc display *display-event-handlers*)))
    589       (if change-handler
    590           (setf (cadr change-handler) handler)
    591           (let ((fd-handler
    592                  (hemlock.wire::add-fd-handler display :input #'call-display-event-handler)))
    593             (push (list display handler fd-handler) *display-event-handlers*)))))
    594 
    595 ;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
    596 ;;; the display to its handler.  If we can't find the display, we remove the
    597 ;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
    598 ;;; display from *display-event-handlers*.  This is necessary to try to keep
    599 ;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
    600 ;;; over.  This is possible since many CMU Common Lisp streams loop over
    601 ;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
    602 ;;; possible.
    603 ;;;
    604   (defun call-display-event-handler (display)
    605     (let ((handler (cadr (assoc display *display-event-handlers*))))
    606       (unless handler
    607         (flush-display-events display)
    608         (error "Display ~S not associated with any event handler." display))
    609       (handler-bind ((error #'(lambda (condx)
    610                                 (declare (ignore condx))
    611                                 (flush-display-events display))))
    612         (funcall handler display))))
    613 
    614   (defun disable-clx-event-handling (display)
    615     "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
    616     (let ((change-handler (assoc display *display-event-handlers*)))
    617       (when change-handler
    618         (hemlock.wire::remove-fd-handler (third change-handler))))
    619     (setf *display-event-handlers*
    620           (delete display *display-event-handlers* :key #'car))
    621     ) )
    622 
    623 
    624 ;;(trace object-set-event-handler hi::invoke-scheduled-events hi::next-scheduled-event-wait serve-event)
    62538
    62639(defun hi::%sp-find-character-with-attribute (string start end table mask)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

    r7833 r7844  
    434434  "Changes the Mark to point to the given character position on the Line,
    435435  which defaults to the line the mark is currently on."
    436   (change-line mark line)
    437   (setf (mark-charpos mark) charpos)
    438   mark)
     436  (when (<= charpos (line-length line))
     437    (change-line mark line)
     438    (setf (mark-charpos mark) charpos)
     439    mark))
    439440
    440441
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp

    r7833 r7844  
    392392  *last-prefix-argument*)
    393393
    394 ;;;
    395 (defvar *invoke-hook* #'(lambda (command p)
    396                           (funcall (command-function command) p))
    397   "This function is called by the command interpreter when it wants to invoke a
    398   command.  The arguments are the command to invoke and the prefix argument.
    399   The default value just calls the Command-Function with the prefix argument.")
    400 
    401 
    402394(defun get-self-insert-command ()
    403395  ;; Get the command used to implement normal character insertion in current buffer.
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp

    r7595 r7844  
    1919;;; you would have to change if you weren't using X11):
    2020;;;    *modifier-translations*
    21 ;;;    DEFINE-CLX-MODIFIER
     21;;;    DEFINE-MODIFIER-BIT
    2222;;;    TRANSLATE-KEY-EVENT
    2323;;;    TRANSLATE-MOUSE-KEY-EVENT
     
    9393    (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)))
    9494
    95 ;;; This is an a-list mapping CLX modifier masks to defined key-event
    96 ;;; modifier names.  DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT
     95;;; This is an a-list mapping native modifier bit masks to defined key-event
     96;;; modifier names.  DEFINE-MODIFIER-BIT fills this in, so TRANSLATE-KEY-EVENT
    9797;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
    9898;;;
     
    412412;;;
    413413
    414 ;;; DEFINE-CLX-MODIFIER -- Public.
    415 ;;;
    416 (defun define-clx-modifier (clx-mask modifier-name)
    417   "This establishes a mapping from clx-mask to a define key-event modifier-name.
     414;;; DEFINE-MODIFIER-BIT -- Public.
     415;;;
     416(defun define-modifier-bit (bit-mask modifier-name)
     417  "This establishes a mapping from bit-mask to a define key-event modifier-name.
    418418   TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events
    419419   with bits defined by this routine."
     
    421421                    :test #'string-equal)))
    422422    (unless map (error "~S an undefined modifier name." modifier-name))
    423     (push (cons clx-mask (car map)) *modifier-translations*)))
     423    (push (cons bit-mask (car map)) *modifier-translations*)))
    424424
    425425;;;
    426426;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
    427 ;;; default clx modifiers, mapping them to some system default key-event
     427;;; default modifiers, mapping them to some system default key-event
    428428;;; modifiers.
    429429;;;
     
    668668  "This blows away all data associated with keysyms, modifiers, mouse
    669669   translations, and key-event/characters mapping.  Then it re-establishes
    670    the system defined key-event modifiers and the system defined CLX
     670   the system defined key-event modifiers and the system defined
    671671   modifier mappings to some of those key-event modifiers.
    672672
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp

    r7833 r7844  
    155155  (cond ((not p)
    156156         (push-buffer-mark (copy-mark (current-point)) t)
    157          (when (interactive)
    158            (message "Mark pushed.")))
     157         (message "Mark pushed."))
    159158        ((= p (value universal-argument-default))
    160159         (pop-and-goto-mark-command nil))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp

    r6 r7844  
    88
    99(in-package :hemlock-ext)
    10 
    11 #+CLISP
    12 (progn
    13   (setf custom:*FLOATING-POINT-CONTAGION-ANSI* t)
    14   (setf custom:*WARN-ON-FLOATING-POINT-CONTAGION* nil))
    1510
    1611(defun getenv (name)
     
    6661                (declare (ignore err))
    6762                nil)) )
    68  
    69 
    70 (defmacro without-gcing (&body body)
    71   `(progn ,@body))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp

    r7618 r7844  
    841841(defindent "with-input-from-region" 1)
    842842(defindent "with-output-to-mark" 1)
    843 (defindent "with-output-to-window" 1)
    844843(defindent "do-strings" 1)
    845844(defindent "save-for-undo" 1)
     
    19931992    (with-input-from-region (s (region mark1 mark2))
    19941993      (let* ((symbol (read s)))
    1995         (make-instance 'ccl::sequence-window-controller
    1996           :sequence (ccl::callers symbol)
    1997           :title (format nil "Callers of ~a" symbol)
    1998           :result-callback #'(lambda (item)
    1999                                (get-def-info-and-go-to-it (symbol-name item)
    2000                                                           (symbol-package item))))))))
     1994        (hemlock-ext:open-sequence-dialog
     1995         :title (format nil "Callers of ~a" symbol)
     1996         :sequence (ccl::callers symbol)
     1997         :action #'edit-definition)))))
     1998
     1999;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed. from anywhere,
     2000;; or it might be called from a sequence dialog, etc.
     2001(defun edit-definition (name)
     2002  (let* ((info (ccl::get-source-files-with-types&classes name)))
     2003    (when (null info)
     2004      (let* ((seen (list name))
     2005             (found ())
     2006             (pname (symbol-name name)))
     2007        (dolist (pkg (list-all-packages))
     2008          (let ((sym (find-symbol pname pkg)))
     2009            (when (and sym (not (member sym seen)))
     2010              (let ((new (ccl::get-source-files-with-types&classes sym)))
     2011                (when new
     2012                  (setq info (append new info))
     2013                  (push sym found)))
     2014              (push sym seen))))
     2015        (when found
     2016          ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
     2017          (loud-message "No definitions for ~s, using ~s instead"
     2018                        name (if (cdr found) found (car found))))))
     2019    (if info
     2020      (if (cdr info)
     2021        (hemlock-ext:open-sequence-dialog
     2022         :title (format nil "Definitions of ~s" name)
     2023         :sequence info
     2024         :action #'(lambda (item) (hemlock-ext:edit-single-definition name item))
     2025         :printer #'(lambda (item stream) (prin1 (car item) stream)))
     2026        (hemlock-ext:edit-single-definition name (car info)))
     2027      (editor-error "No known definitions for ~s" name))))
    20012028
    20022029#||
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp

    r7833 r7844  
    2828  (declare (ignore name new-value))
    2929  (if (eq kind :buffer)
    30     (hi::queue-buffer-change where)))
     30    (hi::note-modeline-change where)))
    3131
    3232(define-file-option "Package" (buffer value)
     
    103103      )
    104104    (let* ((input-mark (variable-value 'buffer-input-mark :buffer buffer)))
    105       (when gui::*read-only-listener*
     105      (when (hemlock-ext:read-only-listener-p)
    106106        (setf (hi::buffer-protected-region buffer)
    107107              (region (buffer-start-mark buffer) input-mark)))
     
    508508
    509509(defun macroexpand-expression (expander)
    510   (let* ((out (hi::top-listener-output-stream)))
    511     (when out
    512       (let* ((point (buffer-point (current-buffer)))
    513              (region (if (region-active-p)
    514                        (current-region)
    515                        (with-mark ((start point))
    516                          (pre-command-parse-check start)
    517                          (with-mark ((end start))
    518                            (unless (form-offset end 1) (editor-error))
    519                            (region start end)))))
    520              (expr (with-input-from-region (s region)
    521                            (read s))))
    522         (let* ((*print-pretty* t))
    523           (format out "~&~s~&" (funcall expander expr)))))))
     510  (let* ((point (buffer-point (current-buffer)))
     511         (region (if (region-active-p)
     512                   (current-region)
     513                   (with-mark ((start point))
     514                     (pre-command-parse-check start)
     515                     (with-mark ((end start))
     516                       (unless (form-offset end 1) (editor-error))
     517                       (region start end)))))
     518         (expr (with-input-from-region (s region)
     519                 (read s))))
     520    (let* ((*print-pretty* t))
     521      (format t "~&~s~&" (funcall expander expr)))))
    524522
    525523(defcommand "Editor Macroexpand-1 Expression" (p)
     
    566564
    567565
    568 ;;; With-Output-To-Window  --  Internal
    569 ;;;
    570 ;;;
    571 (defmacro with-output-to-window ((stream name) &body forms)
    572   "With-Output-To-Window (Stream Name) {Form}*
    573   Bind Stream to a stream that writes into the buffer named Name a la
    574   With-Output-To-Mark.  The buffer is created if it does not exist already
    575   and a window is created to display the buffer if it is not displayed.
    576   For the duration of the evaluation this window is made the current window."
    577   (let ((nam (gensym)) (buffer (gensym)) (point (gensym))
    578         (window (gensym)) (old-window (gensym)))
    579     `(let* ((,nam ,name)
    580             (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam)))
    581             (,point (buffer-end (buffer-point ,buffer)))
    582             (,window (or (car (buffer-windows ,buffer)) (make-window ,point)))
    583             (,old-window (current-window)))
    584        (unwind-protect
    585          (progn (setf (current-window) ,window)
    586                 (buffer-end ,point)
    587                 (with-output-to-mark (,stream ,point) ,@forms))
    588          (setf (current-window) ,old-window)))))
    589 
    590566(defcommand "Editor Compile File" (p)
    591567  "Prompts for file to compile in the editor Lisp.  Does not compare source
     
    597573                             (buffer-default-pathname (current-buffer))
    598574                             :prompt "File to compile: ")))
    599     (with-output-to-window (*error-output* "Compiler Warnings")
    600       (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))
     575    (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
    601576
    602577
     
    627602                                    (namestring pn))))
    628603             (write-buffer-file buf pn)
    629              (with-output-to-window (*error-output* "Compiler Warnings")
    630                (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))
     604             (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
    631605          ((older-or-non-existent-fasl-p pn p)
    632606           (when (or (not (value compile-buffer-file-confirm))
     
    634608                      :default t :default-string "Y"
    635609                      :prompt (list "Compile file ~A? " (namestring pn))))
    636              (with-output-to-window (*error-output* "Compiler Warnings")
    637                (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))
     610             (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
    638611          (t (when (or p
    639612                       (prompt-for-y-or-n
     
    641614                        :prompt
    642615                        "Fasl file up to date, compile source anyway? "))
    643                (with-output-to-window (*error-output* "Compiler Warnings")
    644                  (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))))))
     616               (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))
    645617
    646618
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

    r7833 r7844  
    493493;;;; Stuff from here on is implementation dependant.
    494494
     495(defvar *saved-standard-output* nil)
     496
     497(defmacro with-output-to-listener (&body body)
     498  `(let* ((*saved-standard-output* (or *saved-standard-output*
     499                                       (cons *standard-output* *error-output*)))
     500          (*standard-output* (hemlock-ext:top-listener-output-stream))
     501          (*error-output* *standard-output*))
     502     ,@body))
     503
     504(defmacro with-standard-standard-output (&body body)
     505  `(let* ((*standard-output* (or (car *saved-standard-output*) *standard-output*))
     506          (*error-output* (or (cdr *saved-standard-output*) *error-output*)))
     507     ,@body))
     508
    495509
    496510
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp

    r7833 r7844  
    5858  (%init-syntax-table)
    5959  ;;
    60   ;; Define print representations for funny characters.
    61   (%init-line-image)
    6260  (setq *hemlock-initialized* t))
    6361
     
    255253         *after-editor-initializations-funs*))
    256254
    257 (defun maybe-load-hemlock-init (init)
    258   (when init
    259     (let* ((switch #+NILGB (find "hinit" *command-line-switches*
    260                          :test #'string-equal
    261                          :key #'cmd-switch-name))
    262            (spec-name
    263             (if (not (eq init t))
    264                 init
    265                 (and switch
    266                      (or (cmd-switch-value switch)
    267                          (car (cmd-switch-words switch))))))
    268            (home (user-homedir-pathname)))
    269       (when home
    270         (if spec-name
    271             (load (merge-pathnames spec-name home) :if-does-not-exist nil)
    272             (or (load (merge-pathnames (make-pathname :name "hemlock-init") home)
    273                       :if-does-not-exist nil)
    274                 (load (merge-pathnames (make-pathname :name ".hemlock-init") home)
    275                       :if-does-not-exist nil)))))))
    276 
    277 
    278 
    279255;;;; SAVE-ALL-BUFFERS.
    280256
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp

    r7833 r7844  
    4242
    4343
    44 (declaim (inline modeline-field-name modeline-field-width
    45                  modeline-field-function))
     44(declaim (inline modeline-field-name modeline-field-width modeline-field-function))
    4645
    4746(defun modeline-field-name (ml-field)
     
    6463(declaim (special *buffer-list*))
    6564
    66 (defun %set-modeline-field-width (ml-field width)
    67   (check-type ml-field modeline-field)
    68   (unless (or (eq width nil) (and (integerp width) (plusp width)))
    69     (error "Width must be nil or a positive integer."))
    70   (unless (eql width (modeline-field-%width ml-field))
    71     (setf (modeline-field-%width ml-field) width)
    72     (dolist (b *buffer-list*)
    73       (when (buffer-modeline-field-p b ml-field)
    74         (dolist (w (buffer-windows b))
    75           (update-modeline-fields b w)))))
    76   width)
    77  
    7865(defun modeline-field-function (ml-field)
    7966  "Returns the function of a modeline field object.  It returns a string."
    8067  (modeline-field-%function ml-field))
    81 
    82 (defun %set-modeline-field-function (ml-field function)
    83   (check-type ml-field modeline-field)
    84   (check-type function (or symbol function))
    85   (setf (modeline-field-%function ml-field) function)
    86   (dolist (b *buffer-list*)
    87     (when (buffer-modeline-field-p b ml-field)
    88       (dolist (w (buffer-windows b))
    89         (update-modeline-field b w ml-field))))
    90   function)
    91 
    9268
    9369
     
    178154  (declare (ignore name new-value))
    179155  (if (eq kind :buffer)
    180       (hi::queue-buffer-change where)
    181       (dolist (buffer *buffer-list*)
    182         (when (and (buffer-modeline-field-p buffer :buffer-pathname)
    183                    (buffer-windows buffer))
    184           (hi::queue-buffer-change buffer)))))
     156    (note-modeline-change where)
     157    (dolist (buffer *buffer-list*)
     158      (when (buffer-modeline-field-p buffer :buffer-pathname)
     159        (note-modeline-change buffer)))))
    185160
    186161(defun buffer-pathname-ml-field-fun (buffer window)
     
    244219
    245220(defun %init-mode-redisplay ()
    246   (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change)
    247   (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change)
    248   (add-hook hemlock::buffer-name-hook 'queue-buffer-change)
    249   (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change)
     221  (add-hook hemlock::buffer-major-mode-hook 'note-modeline-change)
     222  (add-hook hemlock::buffer-minor-mode-hook 'note-modeline-change)
     223  (add-hook hemlock::buffer-name-hook 'note-modeline-change)
     224  (add-hook hemlock::buffer-pathname-hook 'note-modeline-change)
    250225  ;; (SETF (BUFFER-MODIFIED ...)) handles updating the modeline;
    251226  ;; it only wants to do so if the buffer's modified state changes.
    252 ;  (add-hook hemlock::buffer-modified-hook 'queue-buffer-change)
     227;  (add-hook hemlock::buffer-modified-hook 'note-modeline-change)
    253228)
    254229
    255 (defun queue-buffer-change (buffer &optional something-else another-else)
    256   (declare (ignore something-else another-else))
    257   (dolist (w (buffer-windows buffer))
    258     (invalidate-modeline w)))
     230(defun note-modeline-change (buffer &rest more)
     231  (declare (ignore more))
     232  (hemlock-ext:invalidate-modeline buffer))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp

    r7833 r7844  
    423423             (page-offset point p))
    424424            (t (goto-page point p)))
    425     (line-start (move-mark (window-display-start (current-window)) point))))
     425    (hemlock-ext:scroll-mark-to-top point)))
    426426
    427427(defun goto-page (mark i)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

    r7833 r7844  
    8585   #:buffer-variables
    8686   #:buffer-modes
    87    #:buffer-windows
    8887   #:buffer-delete-hook
    8988   #:buffer-package
     
    9796   #:buffer-modeline-fields
    9897   #:buffer-modeline-field-p
    99    #:update-modeline-fields
    10098   #:update-modeline-field
    10199   #:insert-character
     
    185183   #:character-attribute-hooks
    186184   #:make-window
    187    #:windowp
    188185   #:delete-window
    189    #:window-display-start
    190    #:window-display-end
    191    #:window-display-recentering
    192    #:window-point
    193    #:center-window
    194    #:scroll-window
    195    #:displayed-p
    196    #:window-height
    197    #:window-width
    198186   #:next-window
    199187   #:previous-window
    200    #:mark-to-cursorpos
    201    #:cursorpos-to-mark
    202    #:last-key-event-cursorpos
    203    #:mark-column
    204    #:move-to-column
    205188   #:show-mark
    206189   #:redisplay
     
    237220   #:pause-hemlock
    238221   #:clear-editor-input
    239    #:listen-editor-input
    240    #:editor-sleep
    241222   #:make-hemlock-output-stream
    242223   #:hemlock-output-stream-p
     
    329310   #:file-comment
    330311   #:without-interrupts
    331    #:without-gcing
    332312   #:define-setf-method
    333313   #:getenv
    334 
    335314   #:delq #:memq #:assq
    336315   #:fixnump
    337316   #:file-writable
    338317     
    339    #:define-keysym #:define-mouse-keysym #:name-keysym #:keysym-names
    340    #:keysym-preferred-name #:define-key-event-modifier #:define-clx-modifier
    341    #:make-key-event-bits #:key-event-modifier-mask #:key-event-bits-modifiers
    342    #:*all-modifier-names* #:translate-key-event #:translate-mouse-key-event
    343    #:make-key-event #:key-event #:key-event-p #:key-event-bits #:key-event-keysym
    344    #:char-key-event #:key-event-char #:key-event-bit-p #:do-alpha-key-events
    345    #:print-pretty-key #:print-pretty-key-event
     318   ;; key-event.lisp
     319   #:define-keysym
     320   #:define-mouse-keysym
     321   #:name-keysym
     322   #:keysym-names
     323   #:keysym-preferred-name
     324   #:define-key-event-modifier
     325   #:define-modifier-bit
     326   #:make-key-event-bits
     327   #:key-event-modifier-mask
     328   #:key-event-bits-modifiers
     329   #:*all-modifier-names*
     330   #:translate-key-event
     331   #:translate-mouse-key-event
     332   #:make-key-event
     333   #:key-event
     334   #:key-event-p
     335   #:key-event-bits
     336   #:key-event-keysym
     337   #:char-key-event
     338   #:key-event-char
     339   #:key-event-bit-p
     340   #:do-alpha-key-events
     341   #:print-pretty-key
     342   #:print-pretty-key-event
    346343
    347344   ;; hemlock-ext.lisp
    348    #:disable-clx-event-handling
    349    #:quit
    350    #:serve-event
    351    #:sap-ref-8
    352    #:make-object-set
    353    #:default-clx-event-handler
    354    #:serve-exposure
    355    #:serve-graphics-exposure
    356    #:serve-no-exposure
    357    #:serve-configure-notify
    358    #:serve-destroy-notify
    359    #:serve-unmap-notify
    360    #:serve-map-notify
    361    #:serve-reparent-notify
    362    #:serve-gravity-notify
    363    #:serve-circulate-notify
    364    #:serve-client-message
    365    #:serve-key-press
    366    #:serve-button-press
    367    #:serve-button-release
    368    #:serve-enter-notify
    369    #:serve-leave-notify
    370    #:flush-display-events
    371    #:object-set-event-handler
    372    #:with-clx-event-handling
    373345   #:complete-file
    374    #:default-directory))
     346   #:default-directory
     347
     348   ;; defined externally (i.e. used by but not defined in hemlock)
     349   #:note-selection-set-by-search
     350   #:center-selection-in-view
     351   #:scroll-mark-to-top
     352   #:scroll-view
     353   #:report-hemlock-error
     354   #:top-listener-output-stream
     355   #:invalidate-modeline
     356   #:note-buffer-saved
     357   #:note-buffer-unsaved
     358   #:read-only-listener-p
     359   #:visible-buffers
     360   #:open-sequence-dialog
     361   #:edit-single-definition
     362   ))
    375363
    376364(defpackage :hemlock-internals
     
    412400   
    413401   ;; rompsite.lisp
    414    #:show-mark #:editor-sleep #:fun-defined-from-pathname
     402   #:show-mark #:fun-defined-from-pathname
    415403   #:editor-describe-function #:pause-hemlock #:store-cut-string
    416404   #:fetch-cut-string #:schedule-event #:remove-scheduled-event
     
    424412
    425413   ;;
    426    #:mark #:mark-line #:mark-charpos #:markp #:region #:region-start #:region-end
     414   #:mark #:mark-line #:mark-charpos #:mark-column #:markp #:region #:region-start #:region-end
    427415   #:regionp #:buffer #:bufferp #:buffer-modes #:buffer-point #:buffer-writable
    428    #:buffer-delete-hook #:buffer-windows #:buffer-variables #:buffer-write-date
    429    #:region #:regionp #:region-start #:region-end #:window #:windowp #:window-height
    430    #:window-width #:window-display-start #:window-display-end #:window-point
    431    #:window-display-recentering #:commandp #:command #:command-function
     416   #:buffer-delete-hook #:buffer-variables #:buffer-write-date
     417   #:region #:regionp #:region-start #:region-end
     418   #:commandp #:command #:command-function
    432419   #:command-documentation #:modeline-field #:modeline-field-p
    433420
    434421   ;; from input.lisp
    435    #:clear-editor-input #:listen-editor-input
    436    #:last-key-event-typed #:*key-event-history*
    437    #:input-waiting #:last-key-event-cursorpos
     422   #:clear-editor-input
     423   #:*key-event-history* #:input-waiting
    438424
    439425   ;; from macros.lisp
     
    445431
    446432   ;; from views.lisp
    447    #:hemlock-view #:current-prefix-argument-state
     433   #:hemlock-view #:current-view
     434   #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed
    448435   #:abort-to-toplevel #:abort-current-command
    449436
     
    479466   ;; charmacs.lisp
    480467   #:syntax-char-code-limit #:search-char-code-limit #:do-alpha-chars
    481 
    482    ;; cursor.lisp
    483    #:mark-to-cursorpos #:center-window #:displayed-p #:scroll-window
    484    #:mark-column #:cursorpos-to-mark #:move-to-column
    485468
    486469   ;; display.lisp
     
    552535   #:*global-variable-names* #:*mode-names* #:*buffer-names*
    553536   #:*character-attribute-names* #:*command-names* #:*buffer-list*
    554    #:*window-list* #:last-key-event-typed #:after-editor-initializations
     537   #:after-editor-initializations
    555538
    556539   ;; screen.lisp
     
    582565   ;; window.lisp
    583566   #:modeline-field-width
    584    #:modeline-field-function #:make-modeline-field #:update-modeline-fields
     567   #:modeline-field-function #:make-modeline-field
    585568   #:update-modeline-field #:modeline-field-name #:modeline-field
    586    #:editor-finish-output #:*window-list*
     569   #:editor-finish-output
    587570
    588571   ))
     
    590573
    591574(defpackage :hemlock
    592   (:use :common-lisp :hemlock-interface :hi :hemlock-ext)
    593 ;;;  (:import-from :hemlock-ext #:delq #:memq #:assq)
    594 ;;;  (:import-from :hemlock-internals #:*fast*)
     575  (:use :common-lisp :hemlock-interface :hemlock-internals :hemlock-ext)
    595576  (:shadowing-import-from #:hemlock-ext
    596577                          #:char-code-limit)
    597   ;;  #+cmu
    598   ;; These are defined in EXTENSONS package in CMUCL
    599   (:shadowing-import-from :hemlock-ext
    600    #:*ALL-MODIFIER-NAMES*
    601    #:ASSQ
    602    #:CHAR-KEY-EVENT
    603    #:DEFAULT-CLX-EVENT-HANDLER
    604    #:DEFAULT-DIRECTORY
    605    #:DEFINE-CLX-MODIFIER
    606    #:DEFINE-KEY-EVENT-MODIFIER
    607    #:DEFINE-KEYSYM
    608    #:DEFINE-MOUSE-KEYSYM
    609    #:DELQ
    610    #:DISABLE-CLX-EVENT-HANDLING
    611    #:DO-ALPHA-KEY-EVENTS
    612    #:FILE-WRITABLE
    613    #:FIXNUMP
    614    #:FLUSH-DISPLAY-EVENTS
    615    #:KEY-EVENT
    616    #:KEY-EVENT-BIT-P
    617    #:KEY-EVENT-BITS
    618    #:KEY-EVENT-BITS-MODIFIERS
    619    #:KEY-EVENT-CHAR
    620    #:KEY-EVENT-KEYSYM
    621    #:KEY-EVENT-MODIFIER-MASK
    622    #:KEY-EVENT-P
    623    #:KEYSYM-NAMES
    624    #:KEYSYM-PREFERRED-NAME
    625    #:MAKE-KEY-EVENT
    626    #:MAKE-KEY-EVENT-BITS
    627    #:MEMQ
    628    #:NAME-KEYSYM
    629    #:OBJECT-SET-EVENT-HANDLER
    630    #:PRINT-PRETTY-KEY
    631    #:PRINT-PRETTY-KEY-EVENT
    632    #:QUIT
    633    #:SERVE-BUTTON-PRESS
    634    #:SERVE-BUTTON-RELEASE
    635    #:SERVE-CIRCULATE-NOTIFY
    636    #:SERVE-CLIENT-MESSAGE
    637    #:SERVE-CONFIGURE-NOTIFY
    638    #:SERVE-DESTROY-NOTIFY
    639    #:SERVE-ENTER-NOTIFY
    640    #:SERVE-EXPOSURE
    641    #:SERVE-GRAPHICS-EXPOSURE
    642    #:SERVE-GRAVITY-NOTIFY
    643    #:SERVE-KEY-PRESS
    644    #:SERVE-LEAVE-NOTIFY
    645    #:SERVE-MAP-NOTIFY
    646    #:SERVE-NO-EXPOSURE
    647    #:SERVE-REPARENT-NOTIFY
    648    #:SERVE-UNMAP-NOTIFY
    649 
    650    ;; These four are from SYSTEM package
    651    #:MAKE-OBJECT-SET
    652    #:SAP-REF-8
    653    #:SERVE-EVENT
    654    #:WITHOUT-INTERRUPTS
    655 
    656    #:TRANSLATE-KEY-EVENT
    657    #:TRANSLATE-MOUSE-KEY-EVENT
    658    #:WITH-CLX-EVENT-HANDLING)
    659578  )
    660579
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/pop-up-stream.lisp

    r6608 r7844  
    1818
    1919
    20 
    21 
    22 ;;;; Line-buffered Stream Methods.
    23 
    24 ;; ###GB we want a more optimized interface
    25 
    2620(defmethod stream-write-char ((stream random-typeout-stream) char)
    27   (with-slots (line-buffered-p) stream
    28     (cond (line-buffered-p
    29            (insert-character (random-typeout-stream-mark stream) char)
    30            (when (and (char= char #\newline)
    31                       (not (random-typeout-stream-no-prompt stream)))
    32              (funcall (device-random-typeout-line-more
    33                        (device-hunk-device
    34                         (window-hunk (random-typeout-stream-window stream))))
    35                       stream 1)))
    36           (t
    37            (insert-character (random-typeout-stream-mark stream) char)))))             
     21  (insert-character (random-typeout-stream-mark stream) char))
    3822
    3923(defmethod stream-write-string ((stream random-typeout-stream) string &optional start end)
     
    4226  (unless (and (eql start 0) (eql end (length string)))
    4327    (setq string (subseq string start end)))
    44   (with-slots (line-buffered-p) stream
    45     (cond (line-buffered-p
    46            (insert-string (random-typeout-stream-mark stream) string)
    47            (unless (random-typeout-stream-no-prompt stream)
    48              (let ((count (count #\newline string)))
    49                (when count
    50                  (funcall (device-random-typeout-line-more
    51                            (device-hunk-device
    52                             (window-hunk (random-typeout-stream-window stream))))
    53                           stream count)))))
    54           (t
    55            (insert-string (random-typeout-stream-mark stream) string)))))
     28  (insert-string (random-typeout-stream-mark stream) string))
    5629
    5730(defmethod stream-finish-output ((stream random-typeout-stream))
    58   (with-slots (line-buffered-p) stream
    59     (cond (line-buffered-p
    60            (random-typeout-redisplay (random-typeout-stream-window stream)))
    61           (t
    62            nil))))
     31  nil)
    6332
    6433(defmethod stream-force-output ((stream random-typeout-stream))
     
    6736(defmethod stream-line-column ((stream random-typeout-stream))
    6837  (mark-charpos (random-typeout-stream-mark stream)))
    69 
    70 ;;; Bitmap line-buffered support.
    71 
    72 ;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to
    73 ;;; a line-buffered-random-typeout-stream on the bitmap.  It does a lot of
    74 ;;; checking to make sure that strings of characters longer than the width of
    75 ;;; the window don't screw us.  The code is a little wierd, so a brief
    76 ;;; explanation is below.
    77 ;;;
    78 ;;; The more-mark is how we tell when we will next need to more.  Each time
    79 ;;; we do a more-prompt, we point the mark at the last visible character in
    80 ;;; the random typeout window.  That way, when the mark is no longer
    81 ;;; DISPLAYED-P, we know it's time to do another more prompt.
    82 ;;;
    83 ;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying
    84 ;;; if there was at least one newline in the last batch of output.  If we
    85 ;;; haven't done a more prompt yet (indicated by a value of T for
    86 ;;; first-more-p), then since we know the end of the buffer isn't visible, we
    87 ;;; need to do a more-prompt.  If neither of the first two tests returns T,
    88 ;;; then we can only need to do a more-prompt if our more-mark has scrolled
    89 ;;; off the top of the screen.  If it hasn't, everything is peechy-keen, so
    90 ;;; we scroll the screen one line and redisplay.
    91 ;;;
    92 (defun update-bitmap-line-buffered-stream (stream newline-count)
    93   (let* ((window (random-typeout-stream-window stream))
    94          (count 0))
    95     (when (plusp newline-count) (random-typeout-redisplay window))
    96     (loop
    97       (cond ((no-text-past-bottom-p window)
    98              (return))
    99             ((or (random-typeout-stream-first-more-p stream)
    100                  (not (displayed-p (random-typeout-stream-more-mark stream)
    101                                    window)))
    102              (do-bitmap-more-prompt stream)
    103              (return))
    104             (t
    105              (scroll-window window 1)
    106              (random-typeout-redisplay window)))
    107       (when (= (incf count) newline-count) (return)))))
    108 
    109 ;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed
    110 ;;; in the random-typeout window.  It does this by first making sure there is a
    111 ;;; line past the WINDOW-DISPLAY-END of the window.  If there is, this line
    112 ;;; must be empty, and BUFFER-END-MARK must be on this line.  The final test is
    113 ;;; that the window-end is displayed within the window.  If it is not, then the
    114 ;;; last line wraps past the end of the window, and there is text past the
    115 ;;; bottom.
    116 ;;;
    117 ;;; Win-end is bound after the call to DISPLAYED-P because it updates the
    118 ;;; window's image moving WINDOW-DISPLAY-END.  We want this updated value for
    119 ;;; the display end.
    120 ;;;
    121 (defun no-text-past-bottom-p (window)
    122   (let* ((window-end (window-display-end window))
    123          (window-end-displayed-p (displayed-p window-end window)))
    124     (with-mark ((win-end window-end))
    125       (let ((one-after-end (line-offset win-end 1)))
    126         (if one-after-end
    127             (and (empty-line-p win-end)
    128                  (same-line-p win-end (buffer-end-mark (window-buffer window)))
    129                  window-end-displayed-p)
    130             window-end-displayed-p)))))
    131 
    132 (defun reset-more-mark (stream)
    133   (let* ((window (random-typeout-stream-window stream))
    134          (more-mark (random-typeout-stream-more-mark stream))
    135          (end (window-display-end window)))
    136     (move-mark more-mark end)
    137     (unless (displayed-p end window) (character-offset more-mark -1))))
    138 
    139 
    140 
    141 
    142 
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp

    r694 r7844  
    3131  "Used with Ring-Push and friends to implement ring buffers."
    3232  (first -1 :type fixnum)          ;The index of the first position used.
    33   (bound (required-argument) :type fixnum)   ;The index after the last element.
    34   delete-function ;The function  to be called on deletion.
    35   (vector (required-argument) :type simple-vector) ;The vector.
     33  (bound -1 :type fixnum)          ;The index after the last element.
     34  delete-function                  ;The function  to be called on deletion.
     35  (vector #() :type simple-vector) ;The vector.
    3636  (lock (ccl:make-lock)))
    3737                         
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp

    r7595 r7844  
    6262  (defhvar "Reverse Video"
    6363    "Paints white on black in window bodies, black on white in modelines."
    64     :value nil
    65     #+clx
    66     :hooks #+clx '(reverse-video-hook-fun))
     64    :value nil)
    6765  (defhvar "Enter Window Hook"
    6866    "When the mouse enters an editor window, this hook is invoked.  These
     
    140138
    141139(declaim (declaration values))
    142 (declaim (special *default-font-family*))
    143140
    144141;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
     
    162159(defvar *line-wrap-char* #\!
    163160  "The character to be displayed to indicate wrapped lines.")
    164 
    165 
    166 
    167 ;;;; Current terminal character translation.
    168 
    169 (defvar termcap-file "/etc/termcap")
    170 
    171161
    172162
     
    274264  "Removes function queued with SCHEDULE-EVENT."
    275265  (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
    276 
    277 
    278 
    279 
    280 ;;;; Editor sleeping.
    281 
    282 (defun editor-sleep (time)
    283   "Sleep for approximately Time seconds."
    284   (unless (or (zerop time) (listen-editor-input *editor-input*))
    285     ;(internal-redisplay)
    286     (sleep-for-time time)
    287     nil))
    288 
    289 (defun sleep-for-time (time)
    290   (timed-wait-for-key-event *editor-input* time))
    291 
    292266
    293267
     
    336310
    337311(defvar *editor-describe-stream*
    338   (#+CMU system:make-indenting-stream #-CMU progn *standard-output*))
     312  #+CMU (system:make-indenting-stream *standard-output*)
     313  #-CMU *standard-output*)
    339314
    340315;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

    r7833 r7844  
    4141
    4242
     43(defun note-current-selection-set-by-search ()
     44  (hemlock-ext:note-selection-set-by-search (current-buffer)))
    4345
    4446
     
    6264               (character-offset point won)
    6365               (push-buffer-mark mark t)
    64                (hi::note-selection-set-by-search))
     66               (note-current-selection-set-by-search))
    6567          (t (delete-mark mark)
    6668             (editor-error)))
     
    8385               (character-offset mark won)
    8486               (push-buffer-mark mark t)
    85                (hi::note-selection-set-by-search))
     87               (note-current-selection-set-by-search))
    8688          (t (delete-mark mark)
    8789             (editor-error)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp

    r7833 r7844  
    3636  A mark's character position is the index within the line of the character
    3737  following the mark.")
     38
     39;; This used to return window position, but for now that's disabled.
     40(defun mark-column (mark)
     41  (mark-charpos mark))
    3842
    3943(defstruct (font-mark (:print-function
     
    108112  variables                   ; string-table of local variables
    109113  write-date                  ; File-Write-Date for pathname.
    110   display-start               ; Window display start when switching to buf.
    111114  %modeline-fields            ; List of modeline-field-info's.
    112115  (delete-hook nil)           ; List of functions to call upon deletion.
     
    129132(setf (documentation 'buffer-point 'function)
    130133  "Return the mark that is the current focus of attention in a buffer.")
    131 (setf (documentation 'buffer-windows 'function)
    132   "Return the list of windows that are displaying a given buffer.")
    133134(setf (documentation 'buffer-variables 'function)
    134135  "Return the string-table of the variables local to the specifed buffer.")
     
    216217
    217218
    218 
    219 
    220 ;#+clx
    221 (progn
    222 ;;;; Windows, dis-lines, and font-changes.
    223 
    224 ;;; The window object:
    225 ;;;
    226   (defstruct (window (:constructor internal-make-window)
    227                      (:predicate windowp)
    228                      (:copier nil)
    229                      (:print-function %print-hwindow))
    230     "This structure implements a Hemlock window."
    231     tick                                ; The last time this window was updated.
    232     %buffer                     ; buffer displayed in this window.
    233     height                      ; Height of window in lines.
    234     width                               ; Width of the window in characters.
    235     old-start                   ; The charpos of the first char displayed.
    236     first-line                  ; The head of the list of dis-lines.
    237     last-line                   ; The last dis-line displayed.
    238     first-changed                       ; The first changed dis-line on last update.
    239     last-changed                        ; The last changed dis-line.
    240     spare-lines                 ; The head of the list of unused dis-lines
    241     (old-lines 0)                       ; Slot used by display to keep state info
    242     hunk                                ; The device hunk that displays this window.
    243     display-start                       ; first character position displayed
    244     display-end                 ; last character displayed
    245     point                               ; Where the cursor is in this window. 
    246     modeline-dis-line           ; Dis-line for modeline display.
    247     modeline-buffer             ; Complete string of all modeline data.
    248     modeline-buffer-len         ; Valid chars in modeline-buffer.
    249     display-recentering)                ; Tells whether redisplay recenters window
    250                                         ;    regardless of whether it is current.
    251 
    252   (setf (documentation 'windowp 'function)
    253         "Returns true if its argument is a Hemlock window object, Nil otherwise.")
    254   (setf (documentation 'window-height 'function)
    255         "Return the height of a Hemlock window in character positions.")
    256   (setf (documentation 'window-width 'function)
    257         "Return the width of a Hemlock window in character positions.")
    258   (setf (documentation 'window-display-start 'function)
    259         "Return the mark which points before the first character displayed in
    260    the supplied window.")
    261   (setf (documentation 'window-display-end 'function)
    262         "Return the mark which points after the last character displayed in
    263    the supplied window.")
    264   (setf (documentation 'window-point 'function)
    265         "Return the mark that points to where the cursor is displayed in this
    266   window.  When the window is made current, the Buffer-Point of this window's
    267   buffer is moved to this position.  While the window is current, redisplay
    268   makes this mark point to the same position as the Buffer-Point of its
    269   buffer.")
    270   (setf (documentation 'window-display-recentering 'function)
    271         "This determines whether redisplay recenters window regardless of whether it
    272   is current.  This is SETF'able.")
    273 
    274   (defstruct (window-dis-line (:copier nil)
    275                               (:constructor make-window-dis-line (chars))
    276                               (:conc-name dis-line-))
    277     chars                             ; The line-image to be displayed.
    278     (length 0 :type fixnum)     ; Length of line-image.
    279     font-changes                ; Font-Change structures for changes in this line.
    280     old-chars                 ; Line-Chars of line displayed.
    281     line                              ; Line displayed.
    282     (flags 0 :type fixnum)      ; Bit flags indicate line status.
    283     (delta 0 :type fixnum)      ; # lines moved from previous position.
    284     (position 0 :type fixnum)   ; Line # to be displayed on.
    285     (end 0 :type fixnum))             ; Index after last logical character displayed.
    286 
    287   (defstruct (font-change (:copier nil)
    288                           (:constructor make-font-change (next)))
    289     x                         ; X position that change takes effect.
    290     font                              ; Index into font-map of font to use.
    291     next                              ; The next Font-Change on this dis-line.
    292     mark)                             ; Font-Mark responsible for this change.
    293 
    294 
    295 
    296 
    297 ;;;; Font family.
    298 
    299   (defstruct font-family
    300     map                 ; Font-map for hunk.
    301     height              ; Height of char box includung VSP.
    302     width                       ; Width of font.
    303     baseline            ; Pixels from top of char box added to Y.
    304     cursor-width                ; Pixel width of cursor.
    305     cursor-height               ; Pixel height of cursor.
    306     cursor-x-offset     ; Added to pos of UL corner of char box to get
    307     cursor-y-offset)    ; UL corner of cursor blotch.
    308 
    309   )
    310 
    311 
    312 
    313219;;;; Attribute descriptors.
    314220
     
    361267                 :initform nil
    362268                 :accessor random-typeout-stream-mark
    363                  :documentation "The buffer point of the associated buffer.")
    364    (window       :initarg :window
    365                  :initform nil
    366                  :accessor random-typeout-stream-window
    367                  :documentation "The hemlock window all this shit is in.")
    368    (more-mark    :initarg :more-mark
    369                  :initform nil
    370                  :accessor random-typeout-stream-more-mark
    371                  :documentation "The mark that is not displayed when we need to more.")
    372    (no-prompt    :initarg :no-prompt
    373                  :initform nil
    374                  :accessor random-typeout-stream-no-prompt
    375                  :documentation "T when we want to exit, still collecting output.")
    376    (first-more-p :initarg :first-more-p
    377                  :initform t
    378                  :accessor random-typeout-stream-first-more-p
    379                  :documentation "T until the first time we more. Nil after.")
    380    (line-buffered-p :documentation "whether line buffered") ))
     269                 :documentation "The buffer point of the associated buffer.")))
    381270
    382271(defun make-random-typeout-stream (mark)
     
    390279             (mark-buffer (random-typeout-stream-mark object))))))
    391280
    392 
    393 
    394 ;;;; Redisplay devices.
    395 
    396 ;;; Devices contain monitor specific redisplay methods referenced by
    397 ;;; redisplay independent code.
    398 ;;;
    399 (defstruct (device (:print-function print-device)
    400                    (:constructor %make-device))
    401   name                  ; simple-string such as "concept" or "lnz".
    402   init                  ; fun to call whenever going into the editor.
    403                         ; args: device
    404   exit                  ; fun to call whenever leaving the editor.
    405                         ; args: device
    406   smart-redisplay       ; fun to redisplay a window on this device.
    407                         ; args: window &optional recenterp
    408   dumb-redisplay        ; fun to redisplay a window on this device.
    409                         ; args: window &optional recenterp
    410   after-redisplay       ; args: device
    411                         ; fun to call at the end of redisplay entry points.
    412   clear                 ; fun to clear the entire display.
    413                         ; args: device
    414   note-read-wait        ; fun to somehow note on display that input is expected.
    415                         ; args: on-or-off
    416   put-cursor            ; fun to put the cursor at (x,y) or (column,line).
    417                         ; args: hunk &optional x y
    418   show-mark             ; fun to display the screens cursor at a certain mark.
    419                         ; args: window x y time
    420   next-window           ; funs to return the next and previous window
    421   previous-window       ;    of some window.
    422                         ; args: window
    423   make-window           ; fun to make a window on the screen.
    424                         ; args: device start-mark
    425                         ;       &optional modeline-string modeline-function
    426   delete-window         ; fun to remove a window from the screen.
    427                         ; args: window
    428   random-typeout-setup  ; fun to prepare for random typeout.
    429                         ; args: device n
    430   random-typeout-cleanup; fun to clean up after random typeout.
    431                         ; args: device degree
    432   random-typeout-line-more ; fun to keep line-buffered streams up to date.
    433   random-typeout-full-more ; fun to do full-buffered  more-prompting.
    434                            ; args: # of newlines in the object just inserted
    435                            ;    in the buffer.
    436   force-output          ; if non-nil, fun to force any output possibly buffered.
    437   finish-output         ; if non-nil, fun to force output and hand until done.
    438                         ; args: device window
    439   beep                  ; fun to beep or flash the screen.
    440   bottom-window-base    ; bottom text line of bottom window.
    441   hunks)                ; list of hunks on the screen.
    442 
    443 (defun print-device (obj str n)
    444   (declare (ignore n))
    445   (format str "#<Hemlock Device ~S>" (device-name obj)))
    446 
    447 
    448 (defstruct (bitmap-device #|(:print-function print-device)|#
    449                           (:include device))
    450   display)                    ; CLX display object.
    451 
    452 
    453 (defstruct (tty-device #|(:print-function print-device)|#
    454                        (:constructor %make-tty-device)
    455                        (:include device))
    456   dumbp                 ; t if it does not have line insertion and deletion.
    457   lines                 ; number of lines on device.
    458   columns               ; number of columns per line.
    459   display-string        ; fun to display a string of characters at (x,y).
    460                         ; args: hunk x y string &optional start end
    461   standout-init         ; fun to put terminal in standout mode.
    462                         ; args: hunk
    463   standout-end          ; fun to take terminal out of standout mode.
    464                         ; args: hunk
    465   clear-lines           ; fun to clear n lines starting at (x,y).
    466                         ; args: hunk x y n
    467   clear-to-eol          ; fun to clear to the end of a line from (x,y).
    468                         ; args: hunk x y
    469   clear-to-eow          ; fun to clear to the end of a window from (x,y).
    470                         ; args: hunk x y
    471   open-line             ; fun to open a line moving lines below it down.
    472                         ; args: hunk x y &optional n
    473   delete-line           ; fun to delete a line moving lines below it up.
    474                         ; args: hunk x y &optional n
    475   insert-string         ; fun to insert a string in the middle of a line.
    476                         ; args: hunk x y string &optional start end
    477   delete-char           ; fun to delete a character from the middle of a line.
    478                         ; args: hunk x y &optional n
    479   (cursor-x 0)          ; column the cursor is in.
    480   (cursor-y 0)          ; line the cursor is on.
    481   standout-init-string  ; string to put terminal in standout mode.
    482   standout-end-string   ; string to take terminal out of standout mode.
    483   clear-to-eol-string   ; string to cause device to clear to eol at (x,y).
    484   clear-string          ; string to cause device to clear entire screen.
    485   open-line-string      ; string to cause device to open a blank line.
    486   delete-line-string    ; string to cause device to delete a line, moving
    487                         ; lines below it up.
    488   insert-init-string    ; string to put terminal in insert mode.
    489   insert-char-init-string ; string to prepare terminal for insert-mode character.
    490   insert-char-end-string ; string to affect terminal after insert-mode character.
    491   insert-end-string     ; string to take terminal out of insert mode.
    492   delete-init-string    ; string to put terminal in delete mode.
    493   delete-char-string    ; string to delete a character.
    494   delete-end-string     ; string to take terminal out of delete mode.
    495   init-string           ; device init string.
    496   cm-end-string         ; takes device out of cursor motion mode.
    497   (cm-x-add-char nil)   ; char-code to unconditionally add to x coordinate.
    498   (cm-y-add-char nil)   ; char-code to unconditionally add to y coordinate.
    499   (cm-x-condx-char nil) ; char-code threshold for adding to x coordinate.
    500   (cm-y-condx-char nil) ; char-code threshold for adding to y coordinate.
    501   (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate.
    502   (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate.
    503   cm-string1            ; initial substring of cursor motion string.
    504   cm-string2            ; substring of cursor motion string between coordinates.
    505   cm-string3            ; substring of cursor motion string after coordinates.
    506   cm-one-origin         ; non-nil if need to add one to coordinates.
    507   cm-reversep           ; non-nil if need to reverse coordinates.
    508   (cm-x-pad nil)        ; nil, 0, 2, or 3 for places to pad.
    509                         ; 0 sends digit-chars.
    510   (cm-y-pad nil)        ; nil, 0, 2, or 3 for places to pad.
    511                         ; 0 sends digit-chars.
    512   screen-image          ; vector device-lines long of strings
    513                         ; device-columns long.
    514   ;;
    515   ;; This terminal's baud rate, or NIL for infinite.
    516   (speed nil :type (or (unsigned-byte 24) null)))
    517 
    518 
    519 
    520 ;;;; Device screen hunks and window-group.
    521 
    522 ;;; Window groups are used to keep track of the old width and height of a group
    523 ;;; so that when a configure-notify event is sent, we can determine if the size
    524 ;;; of the window actually changed or not.
    525 ;;;
    526 (defstruct (window-group (:print-function %print-window-group)
    527                          (:constructor
    528                           make-window-group (xparent width height)))
    529   xparent
    530   width
    531   height)
    532 
    533 (defun %print-window-group (object stream depth)
    534   (declare (ignore object depth))
    535   (format stream "#<Hemlock Window Group>"))
    536281
    537282
     
    549294(defsetf getstring %set-string-table
    550295  "Sets the value for a string-table entry, making a new one if necessary.")
    551 
    552 (defsetf window-buffer %set-window-buffer
    553   "Change the buffer a window is mapped to.")
    554296
    555297(define-setf-expander value (var)
     
    588330  "Set the hook list for a Hemlock character attribute.")
    589331(defsetf ring-ref %set-ring-ref "Set an element in a ring.")
    590 (defsetf current-window %set-current-window "Set the current window.")
    591332(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
    592333(defsetf buffer-region %set-buffer-region "Set a buffer's region.")
     
    606347  "Change the font-object associated with a font-number in new windows.")
    607348
    608 (defsetf buffer-modeline-fields %set-buffer-modeline-fields
    609   "Sets the buffer's list of modeline fields causing all windows into buffer
    610    to be updated for the next redisplay.")
    611349(defsetf modeline-field-name %set-modeline-field-name
    612350  "Sets a modeline-field's name.  If one already exists with that name, an
    613351   error is signaled.")
    614 (defsetf modeline-field-width %set-modeline-field-width
    615   "Sets a modeline-field's width and updates all the fields for all windows
    616    in any buffer whose fields list contains the field.")
    617 (defsetf modeline-field-function %set-modeline-field-function
    618   "Sets a modeline-field's function and updates this field for all windows in
    619    any buffer whose fields list contains the field.")
    620352
    621353;;; Shared buffer-gap context, used to communicate between command threads
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/symbol-completion.lisp

    r7698 r7844  
    103103
    104104(defmethod dabbrev-sources-in ((state (eql :other-buffers)) context)
    105   (let* ((buffers (mapcar #'window-buffer (gui::ordered-hemlock-windows))))
     105  (let* ((buffers (hemlock-ext:visible-buffers)))
    106106    ;; Remove duplicates, always keeping the first occurance (frontmost window)
    107107    (loop for blist on buffers do (setf (cdr blist) (delete (car blist) (cdr blist))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

    r7833 r7844  
    2727(defvar *current-view* nil)
    2828
     29(defun current-view () *current-view*)
     30
    2931(defclass hemlock-view ()
    3032  ((buffer :initarg :buffer :reader hemlock-view-buffer)
     
    6567  (hemlock-prefix-argument-state *current-view*))
    6668
     69(defun last-key-event-typed ()
     70  "This function returns the last key-event typed by the user and read as input."
     71  (hemlock-last-key-event-typed *current-view*))
     72
     73(defun %set-last-key-event-typed (key)
     74  (setf (hemlock-last-key-event-typed *current-view*) key))
     75
     76(defun last-char-typed ()
     77  (let ((key (hemlock-last-key-event-typed *current-view*)))
     78    (when key (hemlock-ext:key-event-char key))))
     79
     80
    6781(defvar *log-event-errors* :backtrace)
    6882
     
    7084;; event handling context for some view.
    7185(defun lisp-error-error-handler (condition)
    72   (handler-case
    73       (let ((emsg (ignore-errors (princ-to-string condition))))
    74         (when *log-event-errors*
    75           ;; Put these in separate ignore-errors, so at least some of it can get thru
    76           (ignore-errors (clear-output *debug-io*))
    77           (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
    78           (when (eq *log-event-errors* :backtrace)
    79             (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
    80               (when err
    81                 (ignore-errors (format *debug-io* "~&Error printing call history - "))
    82                 (ignore-errors (print err *debug-io*))
    83                 (ignore-errors (princ err *debug-io*))
    84                 (ignore-errors (force-output *debug-io*))))))
    85         (report-hemlock-error condition)
    86         (abort-to-toplevel emsg))
    87     (error (cc)
    88       (ignore-errors (format t "~&Event error handling failed"))
    89       (ignore-errors (format t ": ~a" cc))
    90       (abort))))
     86  (with-standard-standard-output
     87    (handler-case
     88        (let ((emsg (ignore-errors (princ-to-string condition))))
     89          (when *log-event-errors*
     90            ;; Put these in separate ignore-errors, so at least some of it can get thru
     91            (ignore-errors (clear-output *debug-io*))
     92            (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
     93            (when (eq *log-event-errors* :backtrace)
     94              (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
     95                (when err
     96                  (ignore-errors (format *debug-io* "~&Error printing call history - "))
     97                  (ignore-errors (print err *debug-io*))
     98                  (ignore-errors (princ err *debug-io*))
     99                  (ignore-errors (force-output *debug-io*))))))
     100          (hemlock-ext:report-hemlock-error *current-view* condition)
     101          (abort-to-toplevel emsg))
     102      (error (cc)
     103             (ignore-errors (format t "~&Event error handling failed"))
     104             (ignore-errors (format t ": ~a" cc))
     105             (abort)))))
    91106
    92107
     
    167182(defvar *last-prefix-argument*)
    168183
     184;;;
     185(defvar *invoke-hook* #'(lambda (command p)
     186                          (funcall (command-function command) p))
     187  "This function is called by the command interpreter when it wants to invoke a
     188  command.  The arguments are the command to invoke and the prefix argument.
     189  The default value just calls the Command-Function with the prefix argument.")
     190
     191
    169192(defmethod execute-hemlock-key ((view hemlock-view) key)
    170193  (if (or (symbolp key) (functionp key))
    171194    (funcall key)
    172     (multiple-value-bind (main-binding transparent-bindings)
    173                          (get-command-binding-for-key view key)
    174       (when main-binding
    175         (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
    176                (*last-prefix-argument* (hemlock::prefix-argument-resetting-state))
    177                ;(*echo-area-stream* (hemlock-echo-area-stream view))
    178                )
    179           (dolist (binding transparent-bindings)
    180             (funcall *invoke-hook* binding *last-prefix-argument*))
    181           (funcall *invoke-hook* main-binding *last-prefix-argument*))))))
     195    (with-output-to-listener
     196      (multiple-value-bind (main-binding transparent-bindings)
     197                           (get-command-binding-for-key view key)
     198        (when main-binding
     199          (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
     200                 (*last-prefix-argument* (hemlock::prefix-argument-resetting-state))
     201                 ;(*echo-area-stream* (hemlock-echo-area-stream view))
     202                 )
     203            (dolist (binding transparent-bindings)
     204              (funcall *invoke-hook* binding *last-prefix-argument*))
     205            (funcall *invoke-hook* main-binding *last-prefix-argument*)))))))
    182206
    183207(defmethod update-echo-area-after-command ((view hemlock-view))
Note: See TracChangeset for help on using the changeset viewer.