Changeset 7993


Ignore:
Timestamp:
Jan 3, 2008, 7:14:48 AM (17 years ago)
Author:
gz
Message:

Various:

Implement prompt-for-key, the last of the prompting suite of functions.

Keep last-command around, not just last-key-event, though ended up not using it.

Stop using pty's for listener input, as they wedge the cocoa thread when the
listener is busy. Use a specialized stream using direct queues, as for output.

With above change, no longer use pty's at all, so stop loading PTY module.

Rearrange recursive setup so view activation happens outside of modifying-buffer-storage.

Fix so with-buffer-bindings doesn't get confused if already wound (can't wait
til I get rid of this whole winding thing!)

make c-n/c-p with numarg at least move to end of range when not enough lines.

API tweaks:

Get rid of *invoke-hook* since not usable in current setup anyway.
Make last-key-event-typed read-only.
Move cocoa-specific part of keysym-defs to cocoa-editor.lisp
Move everything out of hemock-ext, make hemlock-ext be strictly the external support API.

Location:
branches/event-ide/ccl/cocoa-ide
Files:
1 deleted
29 edited

Legend:

Unmodified
Added
Removed

  • branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

    r7933 r7993  
    157157    buf))
    158158
    159 ;;; Define some key event modifiers.
    160 
    161 (hemlock-ext:define-modifier-bit #$NSShiftKeyMask "Shift")
    162 (hemlock-ext:define-modifier-bit #$NSControlKeyMask "Control")
    163 (hemlock-ext:define-modifier-bit #$NSAlternateKeyMask "Meta")
    164 (hemlock-ext:define-modifier-bit #$NSAlphaShiftKeyMask "Lock")
     159;;; Define some key event modifiers and keysym codes
     160
     161(hi:define-modifier-bit #$NSShiftKeyMask "Shift")
     162(hi:define-modifier-bit #$NSControlKeyMask "Control")
     163(hi:define-modifier-bit #$NSAlternateKeyMask "Meta")
     164(hi:define-modifier-bit #$NSAlphaShiftKeyMask "Lock")
     165
     166(hi:define-keysym-code :F1 #$NSF1FunctionKey)
     167(hi:define-keysym-code :F2 #$NSF2FunctionKey)
     168(hi:define-keysym-code :F3 #$NSF3FunctionKey)
     169(hi:define-keysym-code :F4 #$NSF4FunctionKey)
     170(hi:define-keysym-code :F5 #$NSF5FunctionKey)
     171(hi:define-keysym-code :F6 #$NSF6FunctionKey)
     172(hi:define-keysym-code :F7 #$NSF7FunctionKey)
     173(hi:define-keysym-code :F8 #$NSF8FunctionKey)
     174(hi:define-keysym-code :F9 #$NSF9FunctionKey)
     175(hi:define-keysym-code :F10 #$NSF10FunctionKey)
     176(hi:define-keysym-code :F11 #$NSF11FunctionKey)
     177(hi:define-keysym-code :F12 #$NSF12FunctionKey)
     178(hi:define-keysym-code :F13 #$NSF13FunctionKey)
     179(hi:define-keysym-code :F14 #$NSF14FunctionKey)
     180(hi:define-keysym-code :F15 #$NSF15FunctionKey)
     181(hi:define-keysym-code :F16 #$NSF16FunctionKey)
     182(hi:define-keysym-code :F17 #$NSF17FunctionKey)
     183(hi:define-keysym-code :F18 #$NSF18FunctionKey)
     184(hi:define-keysym-code :F19 #$NSF19FunctionKey)
     185(hi:define-keysym-code :F20 #$NSF20FunctionKey)
     186(hi:define-keysym-code :F21 #$NSF21FunctionKey)
     187(hi:define-keysym-code :F22 #$NSF22FunctionKey)
     188(hi:define-keysym-code :F23 #$NSF23FunctionKey)
     189(hi:define-keysym-code :F24 #$NSF24FunctionKey)
     190(hi:define-keysym-code :F25 #$NSF25FunctionKey)
     191(hi:define-keysym-code :F26 #$NSF26FunctionKey)
     192(hi:define-keysym-code :F27 #$NSF27FunctionKey)
     193(hi:define-keysym-code :F28 #$NSF28FunctionKey)
     194(hi:define-keysym-code :F29 #$NSF29FunctionKey)
     195(hi:define-keysym-code :F30 #$NSF30FunctionKey)
     196(hi:define-keysym-code :F31 #$NSF31FunctionKey)
     197(hi:define-keysym-code :F32 #$NSF32FunctionKey)
     198(hi:define-keysym-code :F33 #$NSF33FunctionKey)
     199(hi:define-keysym-code :F34 #$NSF34FunctionKey)
     200(hi:define-keysym-code :F35 #$NSF35FunctionKey)
     201
     202;;; Upper right key bank.
     203;;;
     204(hi:define-keysym-code :Printscreen #$NSPrintScreenFunctionKey)
     205;; Couldn't type scroll lock.
     206(hi:define-keysym-code :Pause #$NSPauseFunctionKey)
     207
     208;;; Middle right key bank.
     209;;;
     210(hi:define-keysym-code :Insert #$NSInsertFunctionKey)
     211(hi:define-keysym-code :Del #$NSDeleteFunctionKey)
     212(hi:define-keysym-code :Home #$NSHomeFunctionKey)
     213(hi:define-keysym-code :Pageup #$NSPageUpFunctionKey)
     214(hi:define-keysym-code :End #$NSEndFunctionKey)
     215(hi:define-keysym-code :Pagedown #$NSPageDownFunctionKey)
     216
     217;;; Arrows.
     218;;;
     219(hi:define-keysym-code :Leftarrow #$NSLeftArrowFunctionKey)
     220(hi:define-keysym-code :Uparrow #$NSUpArrowFunctionKey)
     221(hi:define-keysym-code :Downarrow #$NSDownArrowFunctionKey)
     222(hi:define-keysym-code :Rightarrow #$NSRightArrowFunctionKey)
     223
     224;;;
     225
     226;(hi:define-keysym-code :linefeed 65290)
     227
     228
     229
     230
    165231
    166232
    … …  
    467533
    468534(defmethod assume-not-editing ((ts hemlock-text-storage))
    469   #+debug (assert (eql (slot-value ts 'edit-count) 0)))
     535  #+debug NIL (assert (eql (slot-value ts 'edit-count) 0)))
    470536
    471537(defun textstorage-note-insertion-at-position (self pos n)
    … …  
    851917   (call-next-method)))
    852918
    853 (defconstant +shift-event-mask+ (hemlock-ext:key-event-modifier-mask "Shift"))
     919(defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift"))
    854920
    855921;;; Translate a keyDown NSEvent to a Hemlock key-event.
    … …  
    872938                                              #$NSAlphaShiftKeyMask))))
    873939            (unless quote-p
    874               (dolist (map hemlock-ext::*modifier-translations*)
     940              (dolist (map hi:*modifier-translations*)
    875941                (when (logtest useful-modifiers (car map))
    876942                  (setq bits (logior bits
    877                                      (hemlock-ext:key-event-modifier-mask (cdr map)))))))
     943                                     (hi:key-event-modifier-mask (cdr map)))))))
    878944            (let* ((char (code-char c)))
    879945              (when (and char (standard-char-p char))
    880946                (setq bits (logandc2 bits +shift-event-mask+))))
    881             (hemlock-ext:make-key-event c bits)))))))
     947            (hi:make-key-event c bits)))))))
    882948
    883949;; For now, this is only used to abort i-search.  All actual mouse handling is done
    … …  
    13951461                       (mapcar
    13961462                        #'(lambda (field)
     1463                            #+GZ (or (ignore-errors (funcall (hi::modeline-field-function field)
     1464                                                             buffer pane))
     1465                                     (format nil "#<~s ~s>" (hi::modeline-field-name field)
     1466                                             (and (eq (hi::modeline-field-name field) :package)
     1467                                                  (hi::variable-value 'hemlock::current-package
     1468                                                                      :buffer buffer))))
     1469
     1470                            #-GZ
    13971471                            (funcall (hi::modeline-field-function field)
    13981472                                     buffer pane))
    … …  
    16211695
    16221696(defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane)
    1623   #+GZ (log-debug "change active pane, current: ~s" new-pane)
     1697  #+GZ (log-debug "change active pane to ~s" new-pane)
    16241698  (let* ((pane (hi::hemlock-view-pane view))
    16251699         (text-view (text-pane-text-view pane))
    … …  
    18991973    (setf (slot-value frame 'echo-area-view) echo-area
    19001974          (slot-value frame 'pane) pane)
    1901     #+GZ (log-debug "~&echo-area: ~s textstorage: ~s"
    1902                     echo-area
    1903                     (#/textStorage echo-area))
    19041975    (setf (slot-value pane 'hemlock-view)
    19051976          (make-instance 'hi:hemlock-view
    … …  
    19071978            :pane pane
    19081979            :echo-area-buffer echo-buffer))
    1909 
    19101980    (activate-hemlock-view tv)
    19111981   frame))

  • branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp

    r7931 r7993  
    3131
    3232
    33 ;;; Setup the server end of a pty pair.
    34 (defun setup-server-pty (pty)
    35   (set-tty-raw pty)
    36   pty)
    37 
    38 ;;; Setup the client end of a pty pair.
    39 (defun setup-client-pty (pty)
    40   ;; Since the same (Unix) process will be reading from and writing
    41   ;; to the pty, it's critical that we make the pty non-blocking.
    42   ;; Has this been true for the last few years (native threads) ?
    43   ;(fd-set-flag pty #$O_NONBLOCK)
    44   (set-tty-raw pty)
    45   #+no
    46   (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG))
    47   #+no
    48   (disable-tty-output-modes pty #$ONLCR) 
    49   pty)
     33(defclass cocoa-listener-input-stream (fundamental-character-input-stream)
     34  ((queue :initform ())
     35   (queue-lock :initform (make-lock))
     36   (read-lock :initform (make-lock))
     37   (queue-semaphore :initform (make-semaphore)) ;; total queue count
     38   (text-semaphore :initform (make-semaphore))  ;; text-only queue count
     39   (cur-string :initform nil)
     40   (cur-string-pos :initform 0)
     41   (cur-env :initform nil)
     42   (cur-sstream :initform nil)))
     43
     44(defmethod dequeue-listener-char ((stream cocoa-listener-input-stream) wait-p)
     45  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
     46    (with-lock-grabbed (read-lock)
     47      (or (with-lock-grabbed (queue-lock)
     48            (when (< cur-string-pos (length cur-string))
     49              (prog1 (aref cur-string cur-string-pos) (incf cur-string-pos))))
     50          (loop
     51            (unless (if wait-p
     52                      (wait-on-semaphore text-semaphore nil "Listener Input")
     53                      (timed-wait-on-semaphore text-semaphore 0))
     54              (return nil))
     55            (assert (timed-wait-on-semaphore queue-semaphore 0) () "queue/text mismatch!")
     56            (with-lock-grabbed (queue-lock)
     57              (let* ((s (find-if #'stringp queue)))
     58                (assert s () "queue/semaphore mismatch!")
     59                (setq queue (delq s queue 1))
     60                (when (< 0 (length s))
     61                  (setf cur-string s cur-string-pos 1)
     62                  (return (aref s 0))))))))))
     63
     64(defmethod ccl::read-toplevel-form ((stream cocoa-listener-input-stream) eof-value)
     65  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos cur-sstream cur-env) stream
     66    (with-lock-grabbed (read-lock)
     67      (loop
     68        (when cur-sstream
     69          (let* ((env cur-env)
     70                 (form (progv (car env) (cdr env)
     71                         (ccl::read-toplevel-form cur-sstream eof-value)))
     72                 (last-form-in-selection (not (listen cur-sstream))))
     73            (when last-form-in-selection
     74              (setf cur-sstream nil cur-env nil))
     75            (return (values form env (or last-form-in-selection ccl::*verbose-eval-selection*)))))
     76        (when (with-lock-grabbed (queue-lock)
     77                (loop
     78                  unless (< cur-string-pos (length cur-string)) return nil
     79                  unless (whitespacep (aref cur-string cur-string-pos)) return t
     80                  do (incf cur-string-pos)))
     81          (return (values (call-next-method) nil t)))
     82        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
     83        (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
     84          (cond ((stringp val)
     85                 (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
     86                 (setq cur-string val cur-string-pos 0))
     87                (t
     88                 (destructuring-bind (string package-name pathname) val
     89                   (let ((env (cons '(*loading-file-source-file*) (list pathname))))
     90                     (when package-name
     91                       (push '*package* (car env))
     92                       (push (ccl::pkg-arg package-name) (cdr env)))
     93                     (setf cur-sstream (make-string-input-stream string) cur-env env))))))))))
     94
     95(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname)
     96  (with-slots (queue-lock queue queue-semaphore) stream
     97    (with-lock-grabbed (queue-lock)
     98      (setq queue (nconc queue (list (list string package-name pathname))))
     99      (signal-semaphore queue-semaphore))))
     100
     101(defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string)
     102  (with-slots (queue-lock queue queue-semaphore text-semaphore) stream
     103    (with-lock-grabbed (queue-lock)
     104      (setq queue (nconc queue (list string)))
     105      (signal-semaphore queue-semaphore)
     106      (signal-semaphore text-semaphore))))
     107
     108(defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream))
     109  (dequeue-listener-char stream nil))
     110
     111(defmethod stream-read-char ((stream cocoa-listener-input-stream))
     112  (dequeue-listener-char stream t))
     113
     114(defmethod stream-unread-char ((stream cocoa-listener-input-stream) char)
     115  ;; Can't guarantee the right order of reads/unreads, just make sure not to
     116  ;; introduce any internal inconsistencies (and dtrt for the non-conflict case).
     117  (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
     118    (with-lock-grabbed (queue-lock)
     119      (cond ((>= cur-string-pos (length cur-string))
     120             (push (string char) queue)
     121             (signal-semaphore queue-semaphore)
     122             (signal-semaphore text-semaphore))
     123            ((< 0 cur-string-pos)
     124             (decf cur-string-pos)
     125             (setf (aref cur-string cur-string-pos) char))
     126            (t (setf cur-string (concatenate 'string (string char) cur-string)))))))
     127
     128(defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream))
     129  t)
     130
     131(defmethod stream-clear-input ((stream cocoa-listener-input-stream))
     132  (with-slots (queue-lock cur-string cur-string-pos) stream
     133    (with-lock-grabbed (queue-lock)
     134      (setf cur-string nil cur-string-pos 0))))
     135
    50136
    51137(defparameter $listener-flush-limit 100)
    … …  
    124210    ((input-stream :reader cocoa-listener-process-input-stream)
    125211     (output-stream :reader cocoa-listener-process-output-stream)
    126      (input-peer-stream :reader cocoa-listener-process-input-peer-stream)
    127212     (backtrace-contexts :initform nil
    128213                         :accessor cocoa-listener-process-backtrace-contexts)
    … …  
    130215 
    131216
    132 (defun new-cocoa-listener-process (procname input-fd peer-fd window)
    133   (let* ((input-stream (ccl::make-selection-input-stream
    134                         input-fd
    135                         :peer-fd peer-fd
    136                         :elements-per-buffer (#_fpathconf
    137                                               input-fd
    138                                               #$_PC_MAX_INPUT)
    139                         :encoding :utf-8))
    140          (peer-stream (ccl::make-fd-stream peer-fd :direction :output
    141                                            :sharing :lock
    142                                            :elements-per-buffer
    143                                            (#_fpathconf
    144                                             peer-fd
    145                                             #$_PC_MAX_INPUT)
    146                                            :encoding :utf-8))
     217(defun new-cocoa-listener-process (procname window)
     218  (let* ((input-stream (make-instance 'cocoa-listener-input-stream))
    147219         (output-stream (make-instance 'cocoa-listener-output-stream
    148220                          :hemlock-view (hemlock-view window)))
    149 
     221         
    150222         (proc
    151223          (ccl::make-mcl-listener-process
    … …  
    174246    (setf (slot-value proc 'input-stream) input-stream)
    175247    (setf (slot-value proc 'output-stream) output-stream)
    176     (setf (slot-value proc 'input-peer-stream) peer-stream)
    177248    (setf (slot-value proc 'window) window)
    178249    proc))
    179 
    180 
     250 
    181251(defclass hemlock-listener-frame (hemlock-frame)
    182252    ()
    … …  
    186256
    187257(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
    188     ((filehandle :foreign-type :id)     ;Filehandle for I/O
    189      (clientfd :foreign-type :int)      ;Client (listener)'s side of pty
    190      )
     258    ()
    191259  (:metaclass ns:+ns-object)
    192260  )
    … …  
    199267  (declare (ignorable edited)))
    200268 
    201 
    202 (objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w)
    203   (let* ((new (call-next-method w)))
    204     (unless (%null-ptr-p new)
    205       (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
    206         (when server
    207           (let* ((fh (make-instance
    208                       'ns:ns-file-handle
    209                       :with-file-descriptor (setup-server-pty server)
    210                       :close-on-dealloc t)))
    211             (setf (slot-value new 'filehandle) fh)
    212             (setf (slot-value new 'clientfd) (setup-client-pty client))))))
    213     new))
    214269
    215270(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
    … …  
    252307(defmethod textview-background-color ((doc hemlock-listener-document))
    253308  *listener-background-color*)
    254 
    255 (defun hemlock-ext:send-string-to-listener (buffer string)
    256   (let* ((proc (buffer-process buffer)))
    257     (when proc
    258       (send-string-to-listener-process proc string))))
    259309
    260310;; For use with the :process-info listener modeline field
    … …  
    370420              *next-listener-y-pos* (ns:ns-point-y new-point))))
    371421    (setf (hemlock-document-process self)
    372           (let* ((tty (slot-value controller 'clientfd))
    373                  (peer-tty (#/fileDescriptor (slot-value controller 'filehandle))))
    374             (new-cocoa-listener-process listener-name tty peer-tty window)))
     422          (new-cocoa-listener-process listener-name window))
    375423    controller))
    376424
    … …  
    521569                            (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))))))
    522570
     571
     572(defmethod eval-in-listener-process ((process cocoa-listener-process)
     573                                     string &key path package)
     574  (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string
     575                         :package-name package :pathname path))
     576
    523577;;; This is basically used to provide INPUT to the listener process, by
    524 ;;; writing to an fd which is conntected to that process's standard
     578;;; writing to an fd which is connected to that process's standard
    525579;;; input.
    526 (defmethod send-string-to-listener-process ((process cocoa-listener-process)
    527                                             string &key path package)
    528   (let* ((stream (cocoa-listener-process-input-peer-stream process)))
    529     (labels ((out-raw-char (ch)
    530                (write-char ch stream))
    531              (out-ch (ch)
    532                (when (or (eql ch #\^v)
    533                          (eql ch #\^p)
    534                          (eql ch #\newline)
    535                          (eql ch #\^q)
    536                          (eql ch #\^d))
    537                  (out-raw-char #\^q))
    538                (out-raw-char ch))
    539              (out-string (s)
    540                (dotimes (i (length s))
    541                  (out-ch (char s i)))))
    542       (out-raw-char #\^p)
    543       (when package (out-string package))
    544       (out-raw-char #\newline)
    545       (out-raw-char #\^v)
    546       (when path (out-string path))
    547       (out-raw-char #\newline)
    548       (out-string string)
    549       (out-raw-char #\^d)
    550       (force-output stream))))
     580(defun hemlock-ext:send-string-to-listener (listener-buffer string)
     581  (let* ((process (buffer-process listener-buffer)))
     582    (unless process
     583      (error "No listener process found for ~s" listener-buffer))
     584    (enqueue-listener-input (cocoa-listener-process-input-stream process) string)))
     585
    551586
    552587
    … …  
    570605    (when target-listener
    571606      (destructuring-bind (package path string) selection
    572         (send-string-to-listener-process target-listener string :package package :path path)))))
     607        (eval-in-listener-process target-listener string :package package :path path)))))
    573608
    574609(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
    … …  
    577612      (destructuring-bind (package path) selection
    578613        (let ((string (format nil "(load ~S)" path)))
    579           (send-string-to-listener-process target-listener string :package package :path path))))))
     614          (eval-in-listener-process target-listener string :package package :path path))))))
    580615
    581616(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
    … …  
    584619      (destructuring-bind (package path) selection
    585620        (let ((string (format nil "(compile-file ~S)" path)))
    586           (send-string-to-listener-process target-listener string :package package :path path))))))
     621          (eval-in-listener-process target-listener string :package package :path path))))))
    587622
    588623(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
    … …  
    595630                                             :name (pathname-name path)
    596631                                             :type (pathname-type path)))))
    597           (send-string-to-listener-process target-listener string :package package :path path))))))
     632          (eval-in-listener-process target-listener string :package package :path path))))))
    598633
    599634       

  • branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp

    r7844 r7993  
    3232  '("package"
    3333
    34     ;; Lisp implementation specific stuff goes into one of
    35     ;; the next two files.
    36     "lispdep"
    3734    "hemlock-ext"                     
    3835               

  • branches/event-ide/ccl/cocoa-ide/defsystem.lisp

    r7698 r7993  
    1616
    1717(require "OBJC-SUPPORT")
    18 
    19 (require "PTY")
    20 
    2118
    2219(defpackage "GUI"
    … …  
    5552   objc-message-send
    5653   open-main-bundle
    57    ;; Symbols perhaps that should be exported by library;pty.lisp but aren't
    58    open-pty-pair
    59    set-tty-raw
    6054   )
    6155  (:export

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

    r7922 r7993  
    3737;;; Self insert letters:
    3838;;;
    39 (hemlock-ext:do-alpha-key-events (key-event :both)
    40                                  (bind-key "Self Insert" key-event))
     39(do-alpha-key-events (key-event :both)
     40  (bind-key "Self Insert" key-event))
    4141
    4242(bind-key "Beginning of Line" #k"control-a")
    … …  
    568568(do ((i 33 (1+ i)))
    569569    ((= i 126))
    570   (let ((key-event (hemlock-ext:char-key-event (code-char i))))
     570  (let ((key-event (hi:char-key-event (code-char i))))
    571571    (bind-key "Self Overwrite" key-event :mode "Overwrite")))
    572572
    … …  
    631631;;; message about modifying read-only buffers.
    632632;;;
    633 (hemlock-ext:do-alpha-key-events (key-event :both)
    634                                  (bind-key "Illegal" key-event :mode "Headers")
    635                                  (bind-key "Illegal" key-event :mode "Message"))
     633(do-alpha-key-events (key-event :both)
     634  (bind-key "Illegal" key-event :mode "Headers")
     635  (bind-key "Illegal" key-event :mode "Message"))
    636636
    637637;;; Global.
    … …  
    725725;;; message about modifying read-only buffers.
    726726;;;
    727 (hemlock-ext:do-alpha-key-events (key-event :both)
    728                                  (bind-key "Illegal" key-event :mode "News-Headers")
    729                                  (bind-key "Illegal" key-event :mode "News-Message"))
     727(do-alpha-key-events (key-event :both)
     728  (bind-key "Illegal" key-event :mode "News-Headers")
     729  (bind-key "Illegal" key-event :mode "News-Message"))
    730730
    731731
    … …  
    934934;;;; Caps-Lock mode.
    935935
    936 (hemlock-ext:do-alpha-key-events (key-event :lower)
    937                                  (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK"))
     936(do-alpha-key-events (key-event :lower)
     937  (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK"))
    938938
    939939
    … …  
    943943;;;; Anything that's not explicitly bound here will exit i-search.
    944944
    945 (dotimes (n hemlock::char-code-limit)
     945(dotimes (n hi::hemlock-char-code-limit)
    946946  (when (standard-char-p (code-char n))
    947     (let ((key (hemlock-ext:make-key-event n)))
     947    (let ((key (make-key-event n)))
    948948      (bind-key "I-Search Self Insert" key :mode "I-Search"))))
    949949

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp

    r7913 r7993  
    150150;;;
    151151(defun unwind-bindings (buffer mode)
    152   #+gz (assert (buffer-bindings-wound-p buffer))
     152  (assert (buffer-bindings-wound-p buffer))
    153153  (setf (buffer-bindings-wound-p buffer) nil)
    154154  (unbind-variable-bindings (buffer-var-values buffer))
    … …  
    167167;;;
    168168(defun wind-bindings (buffer modes)
    169   #+gz (assert (not (buffer-bindings-wound-p buffer)))
     169  (assert (not (buffer-bindings-wound-p buffer)))
    170170  (setf (buffer-bindings-wound-p buffer) t)
    171171  (do ((curmode (buffer-mode-objects buffer)) cw)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/charmacs.lisp

    r6577 r7993  
    3131;;;; Stuff for the Syntax table functions (syntax)
    3232
    33 (defconstant syntax-char-code-limit char-code-limit
     33(defconstant syntax-char-code-limit hemlock-char-code-limit
    3434  "The highest char-code which a character argument to the syntax
    3535  table functions may have.")

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

    r7934 r7993  
    250250  "Moves the down p lines, collapsing the selection."
    251251  (let* ((point (current-point-collapsing-selection))
    252          (target (set-target-column point)))
    253     (unless (line-offset point (or p 1))
    254       (when (value next-line-inserts-newlines)
    255         (cond ((not p)
    256                (when (same-line-p point (buffer-end-mark (current-buffer)))
    257                  (line-end point))
    258                (insert-character point #\newline))
    259               ((minusp p)
    260                (buffer-start point)
    261                (editor-error "No previous line."))
    262               (t
    263                (buffer-end point)
    264                (when p (editor-error "No next line."))))))
     252         (target (set-target-column point))
     253         (count (or p 1)))
     254    (unless (line-offset point count)
     255      (cond ((and (not p) (value next-line-inserts-newlines))
     256             (when (same-line-p point (buffer-end-mark (current-buffer)))
     257               (line-end point))
     258             (insert-character point #\newline))
     259            ((minusp count)
     260             (buffer-start point)
     261             (editor-error "No previous line."))
     262            (t
     263             (buffer-end point)
     264             (editor-error "No next line."))))
    265265    (unless (move-to-position point target) (line-end point))
    266266    (setf (last-command-type) :line-motion)))
    … …  
    482482  (let* ((ps (current-prefix-argument-state))
    483483         (key-event (last-key-event-typed))
    484          (stripped-key-event (hemlock-ext:make-key-event key-event))
    485          (char (hemlock-ext:key-event-char stripped-key-event))
     484         (stripped-key-event (make-key-event key-event))
     485         (char (key-event-char stripped-key-event))
    486486         (digit (if char (digit-char-p char))))
    487487    (when (null (ps-result ps))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp

    r7844 r7993  
    176176  which is prompted for."
    177177  (declare (ignore p))
    178   (multiple-value-bind (key res) (prompt-for-command-key)
     178  (multiple-value-bind (key res) (prompt-for-key :prompt "Describe key: "
     179                                                 :must-exist t)
    179180    (cond ((commandp res)
    180181           (with-pop-up-display (s :title "Key documentation")
    181              (hemlock-ext:print-pretty-key key s)
     182             (write-string (pretty-key-string key) s)
    182183             (format s " is bound to ~S.~%" (command-name res))
    183184             (format s "Documentation for this command:~%   ~A"
    … …  
    185186          (t
    186187           (with-pop-up-display (s :height 1)
    187              (hemlock-ext:print-pretty-key key s)
     188             (write-string (pretty-key-string key) s)
    188189             (write-string " is not bound to anything." s))))))
    189190
    … …  
    308309                           *describe-mode-ignore*
    309310                           :test #'string-equal)
    310              (let ((str (key-to-string key)))
     311             (let ((str (pretty-key-string key)))
    311312               (cond ((= (length str) 1)
    312313                      (write-string str s)
    … …  
    317318       :mode name))))
    318319                   
    319 (defun key-to-string (key)
    320   (with-output-to-string (s)
    321     (hemlock-ext:print-pretty-key key s)))
    322 
    323 
    324 
    325 
    326320;;;; Printing bindings and last N characters typed.
    327321
    … …  
    335329      (do ((i (1- num) (1- i)))
    336330          ((minusp i))
    337         (hemlock-ext:print-pretty-key-event (ring-ref *key-event-history* i) s)
     331        (write-string (pretty-key-string (ring-ref *key-event-history* i)) s)
    338332        (write-char #\space s)))))
    339333
    … …  
    373367  (do ((key keys (cdr key)))
    374368      ((null (cdr key))
    375        (hemlock-ext:print-pretty-key (car key) stream))
    376     (hemlock-ext:print-pretty-key (car key) stream)
     369       (write-string (pretty-key-string (car key)) stream))
     370    (write-string (pretty-key-string (car key)) stream)
    377371    (write-string ", " stream)))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7922 r7993  
    4242  ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
    4343  ;; want to address that.
    44     (if *current-view*
    45       (let ((message (apply #'format nil string args)))
    46         (modifying-echo-buffer
    47           (delete-region (buffer-region *current-buffer*))
    48          (insert-string (buffer-point *current-buffer*) message)
    49          (setq *last-message-time* (get-internal-real-time))
    50          ))
    51       ;; For some reason this crashes.  Perhaps something is too aggressive about
    52       ;; catching conditions in events??
    53       #+not-yet(apply #'warn string args)
    54       #-not-yet (apply #'format t string args)))
     44  (if *current-view*
     45    (let ((message (apply #'format nil string args)))
     46      (modifying-echo-buffer
     47       (delete-region (buffer-region *current-buffer*))
     48       (insert-string (buffer-point *current-buffer*) message)
     49       (setq *last-message-time* (get-internal-real-time))
     50       ))
     51    ;; For some reason this crashes.  Perhaps something is too aggressive about
     52    ;; catching conditions in events??
     53    #+not-yet(apply #'warn string args)
     54    #-not-yet (apply #'format t string args)))
    5555
    5656;;; LOUD-MESSAGE -- Public.
    … …  
    163163     (when old-eps
    164164       (editor-error "Attempt to recursively use echo area"))
    165      (unwind-protect
    166          (let ((*recursive-edit-view* view))
    167            (setf (hemlock-prompted-input-state view) eps)
    168            (unless old-eps
    169              (hemlock-ext:change-active-pane view :echo))
    170            (display-prompt-nicely eps)
    171            (modifying-buffer-storage (nil)
    172              (with-standard-standard-output
    173               (gui::event-loop #'(lambda () (eps-parse-results eps)))))
    174            #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
    175        (setf (hemlock-prompted-input-state view) old-eps)
    176        (unless old-eps
    177          (hemlock-ext:change-active-pane view :text))
    178        (delete-mark parse-mark))
     165     (display-prompt-nicely eps)
     166     (modifying-buffer-storage (nil)
     167       (unwind-protect
     168            (let ((*recursive-edit-view* view))
     169              (setf (hemlock-prompted-input-state view) eps)
     170              (unless old-eps
     171                (hemlock-ext:change-active-pane view :echo))
     172              (with-standard-standard-output
     173                  (gui::event-loop #'(lambda () (eps-parse-results eps))))
     174              #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
     175         (unless old-eps
     176           (hemlock-ext:change-active-pane view :text))
     177         (setf (hemlock-prompted-input-state view) old-eps)
     178         (delete-mark parse-mark)))
    179179     (let ((results (eps-parse-results eps)))
    180180       (if (listp results)
    … …  
    519519                                     (values (list (equalp (eps-parse-default eps) "y")) t))
    520520                                    ((logical-key-event-p key-event :abort)
    521                                      (values nil nil)) ;; default action
     521                                     :abort)
    522522                                    ((logical-key-event-p key-event :help)
    523                                      (values nil nil)) ;; default action
     523                                     :help)
    524524                                    (t
    525525                                     (if (eps-parse-value-must-exist eps)
    526                                        (values nil nil) ;; default action
     526                                       :error
    527527                                       (values (list key-event) t)))))
    528528   :type :key
    … …  
    551551   :key-handler (getstring "Key Input Handler" *command-names*)))
    552552
    553 #+not-yet
    554 (defun prompt-for-key (&key (must-exist t)
    555                             default default-string
    556                             (prompt "Key: ")
    557                             (help "Type a key."))
    558   (let ((string (if default
    559                   (or default-string
    560                       (let ((l (coerce default 'list)))
    561                         (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
    562     (with-echo-area-window
    563      (display-prompt-nicely prompt string)
    564      (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
    565            (declare (vector key))
    566            TOP
    567            (setf key-event (recursive-get-key-event *editor-input*))
    568            (cond ((logical-key-event-p key-event :quote)
    569                   (setf key-event (recursive-get-key-event *editor-input* t)))
    570                  ((logical-key-event-p key-event :confirm)
    571                   (cond ((and default (zerop (length key)))
    572                          (let ((res (get-command default :current)))
    573                            (unless (commandp res) (go FLAME))
    574                            (return (values default res))))
    575                         ((and (not must-exist) (plusp (length key)))
    576                          (return (copy-seq key)))
    577                         (t
    578                          (go FLAME))))
    579                  ((logical-key-event-p key-event :help)
    580                   (hemlock::help-on-parse-command ())
    581                   (go TOP)))
    582            (vector-push-extend key-event key)   
    583            (when must-exist
    584              (let ((res (get-command key :current)))
    585                (cond ((commandp res)
    586                       (hemlock-ext:print-pretty-key-event key-event
    587                                                           *echo-area-stream*
    588                                                           t)
    589                       (write-char #\space *echo-area-stream*)
    590                       (return (values (copy-seq key) res)))
    591                      ((not (eq res :prefix))
    592                       (vector-pop key)
    593                       (go FLAME)))))
    594            (hemlock-ext:print-pretty-key key-event *echo-area-stream* t)
    595            (write-char #\space *echo-area-stream*)
    596            (go TOP)
    597            FLAME
    598            (beep)
    599            (go TOP))
    600      (force-output *echo-area-stream*))))
    601 
    602 #+not-yet
    603 (defun prompt-for-command-key ()
    604   (with-echo-area-window
    605    (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0)))
    606      (hi::display-prompt-nicely "Describe key: " nil)
    607      (loop
    608        (let ((key-event (get-key-event hi::*editor-input*)))
    609          (vector-push-extend key-event prompt-key)
    610          (let ((res (get-command prompt-key :current)))
    611            (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
    612            (write-char #\space *echo-area-stream*)
    613            (unless (eq res :prefix)
    614              (return (values (copy-seq prompt-key) res)))))))))
     553(defun verify-key (eps key-event key quote-p)
     554  ;; This is called with the echo buffer as the current buffer.  We want to look
     555  ;; up the commands in the main buffer.
     556  (let* ((buffer (hemlock-view-buffer (current-view)))
     557         (n (length key)))
     558    (block nil
     559      (unless quote-p
     560        (cond ((logical-key-event-p key-event :help)
     561               (return :help))
     562              ((logical-key-event-p key-event :abort)
     563               (return :abort))
     564              ((and (not (eps-parse-value-must-exist eps))
     565                    (logical-key-event-p key-event :confirm))
     566               (return
     567                 (cond ((eql n 0)
     568                        (let ((key (eps-parse-default eps))
     569                              (cmd (and key (with-buffer-bindings (buffer)
     570                                              (get-command key :current)))))
     571                          (if (commandp cmd)
     572                            (values (list key cmd) :confirmed)
     573                            :error)))
     574                       ((> n 0)
     575                        (values (list key nil) :confirmed))
     576                       (t :error))))))
     577      (vector-push-extend key-event key)
     578      (let ((cmd (if (eps-parse-value-must-exist eps)
     579                   (with-buffer-bindings (buffer) (get-command key :current))
     580                   :prefix)))
     581        (cond ((commandp cmd)
     582               (values (list key cmd) t))
     583              ((eq cmd :prefix)
     584               nil)
     585              (t
     586               (vector-pop key)
     587               :error))))))
     588
     589(defun prompt-for-key (&key (prompt "Key: ")
     590                            (help "Type a key.")
     591                            default default-string
     592                            (must-exist t))
     593  (parse-for-something
     594   :verification-function (let ((key (make-array 10 :adjustable t :fill-pointer 0))
     595                                (quote-p nil))
     596                            #'(lambda (eps key-event)
     597                                (if (and (not quote-p) (logical-key-event-p key-event :quote))
     598                                  (progn
     599                                    (setq quote-p t)
     600                                    (values :ignore nil))
     601                                  (verify-key eps key-event key (shiftf quote-p nil)))))
     602   :type :command
     603   :prompt prompt
     604   :help help
     605   :value-must-exist must-exist
     606   :default default
     607   :default-string default-string
     608   :key-handler (getstring "Key Input Handler" *command-names*)))
    615609
    616610
    … …  
    756750                (cdr key-events)))
    757751              ((null key-events))
    758             (hemlock-ext:print-pretty-key (car key-events) s)
     752            (write-string (pretty-key-string (car key-events)) s)
    759753            (unless (null (cdr key-events))
    760754              (write-string ", " s))))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

    r7919 r7993  
    121121  (multiple-value-bind
    122122      (result win)
    123       (hemlock-ext:complete-file typein
    124                                  :defaults (directory-namestring (eps-parse-default eps))
    125                                  :ignore-types (value ignore-file-types))
     123      (complete-file typein
     124                     :defaults (directory-namestring (eps-parse-default eps))
     125                     :ignore-types (value ignore-file-types))
    126126    (when result
    127127      (replace-parse-input-string eps (namestring result)))
    … …  
    344344;;
    345345
     346(defun append-key-name (key-event)
     347  (let ((point (current-point)))
     348    (insert-string point (pretty-key-string key-event t))
     349    (insert-character point #\Space)))
     350
    346351(defcommand "Key Input Handler" (p)
    347352  "Internal command to handle input during y-or-n or key-event prompting"
    … …  
    349354  (let* ((eps (current-echo-parse-state))
    350355         (key-event (last-key-event-typed)))
    351     (multiple-value-bind (res flag)
     356    (multiple-value-bind (res exit-p)
    352357                         (funcall (eps-parse-verification-function eps) eps key-event)
    353       (if flag
    354         (exit-echo-parse eps res)
    355         (cond ((logical-key-event-p key-event :abort)
    356                (abort-to-toplevel))
    357               ((logical-key-event-p key-event :help)
    358                (hemlock::help-on-parse-command nil))
    359               (t (beep)))))))
     358      #+GZ (log-debug "Key Input Hander: res: ~s exit-p ~s" res exit-p)
     359      (cond (exit-p
     360             (unless (eq exit-p :confirmed)
     361               (append-key-name key-event))
     362             (exit-echo-parse eps res))
     363            ((eq res :abort)
     364             (abort-to-toplevel))
     365            ((eq res :help)
     366             (help-on-parse-command nil))
     367            ((eq res :error)
     368             (beep))
     369            ((eq res :ignore)
     370             nil)
     371            (t
     372             (append-key-name key-event))))))
     373

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp

    r7913 r7993  
    110110      (name command)
    111111      (if p
    112           (multiple-value-bind (key cmd)
    113                                (prompt-for-key :prompt "Edit command bound to: ")
    114             (declare (ignore key))
    115             (values (command-name cmd) cmd))
    116           (prompt-for-keyword :tables (list *command-names*)
    117                               :prompt "Command to edit: "))
     112        (multiple-value-bind (key cmd)
     113                             (prompt-for-key :prompt "Edit command bound to: "
     114                                             :must-exist t)
     115          (declare (ignore key))
     116          (values (command-name cmd) cmd))
     117        (prompt-for-keyword :tables (list *command-names*)
     118                            :prompt "Command to edit: "))
    118119    (go-to-definition (fun-defined-from-pathname (command-function command))
    119120                      :function

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

    r7913 r7993  
    401401  (let* ((pathname (pathname pathname))
    402402         (trial-pathname (or (probe-file pathname)
    403                              (merge-pathnames pathname (hemlock-ext:default-directory))))
     403                             (merge-pathnames pathname (default-directory))))
    404404         (found (find trial-pathname (the list *buffer-list*)
    405405                     :key #'buffer-pathname :test #'equal)))
    … …  
    515515    (setf (buffer-modified buffer) nil)
    516516    (let ((stored-pathname (or probed-pathname
    517                                (merge-pathnames pathname (hemlock-ext:default-directory)))))
     517                               (merge-pathnames pathname (default-directory)))))
    518518      (setf (buffer-pathname buffer) stored-pathname)
    519519      (setf (value pathname-defaults) stored-pathname)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp

    r7844 r7993  
    129129                         (get-command #k"Linefeed" :current)
    130130      (declare (ignore command)) ;command is this one, so don't invoke it
    131       (dolist (c t-bindings) (funcall *invoke-hook* c p)))
     131      (dolist (c t-bindings) (invoke-command c p)))
    132132    (indent-new-line-command nil)))
    133133
    … …  
    148148                         (get-command #k"Return" :current)
    149149      (declare (ignore command)) ;command is this one, so don't invoke it
    150       (dolist (c t-bindings) (funcall *invoke-hook* c p)))
     150      (dolist (c t-bindings) (invoke-command c p)))
    151151    (new-line-command nil)))
    152152

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp

    r7844 r7993  
    1 ;;; -*- Mode: LISP; Package: HEMLOCK-EXT -*-
     1;;; -*- Mode: LISP; Package: Hemlock-Internals -*-
    22
    3 (in-package :hemlock-ext)
     3(in-package :hemlock-internals)
    44
    5 (defconstant hi::char-code-limit 256)
    6 (defconstant char-code-limit 256)
     5(defconstant hemlock-char-code-limit 256)
    76
    8 (defmacro file-comment (&rest ignore)
    9   (declare (ignore ignore))
    10   nil)
    11 
    12 (defun skip-whitespace (&optional (stream *standard-input*))
    13   (peek-char t stream))
    14 
    15 (defvar hi::*command-line-switches* nil)
    16 
    17 (defun hi::get-terminal-name ()
    18   "vt100")
    19 
    20 (defun hi::get-termcap-env-var ()
    21   (getenv "TERMCAP"))
     7(defvar *command-line-switches* nil)
    228
    239(defun default-directory ()
    … …  
    2713  (truename #p""))
    2814
     15(defun file-writable (pathname)
     16  "File-writable accepts a pathname and returns T if the current
     17  process can write it, and NIL otherwise. Also if the file does
     18  not exist return T."
     19  #+(or CMU scl)
     20  (ext:file-writable pathname)
     21  #-(or cmu scl)
     22  (handler-case (let ((io (open pathname
     23                                :direction :output
     24                                :if-exists :append
     25                                :if-does-not-exist nil)))
     26                  (if io
     27                      (close io :abort t)
     28                      ;; more complicate situation:
     29                      ;; we want test if we can create the file.
     30                      (let ((io (open pathname
     31                                      :direction :output
     32                                      :if-exists nil
     33                                      :if-does-not-exist :create)))
     34                        (if io
     35                            (progn
     36                              (close io)
     37                              (delete-file io))
     38                            t))))
     39    (file-error (err)
     40                (declare (ignore err))
     41                nil)) )
     42
    2943
    3044;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    3145
    32 (defun hi::%sp-byte-blt (src start dest dstart end)
     46(defun %sp-byte-blt (src start dest dstart end)
    3347  (declare (type (simple-base-string src dest)))
    3448  (loop for s from start
    … …  
    3751        (setf (aref dest d) (aref src s))))
    3852
    39 (defun hi::%sp-find-character-with-attribute (string start end table mask)
     53(defun %sp-find-character-with-attribute (string start end table mask)
    4054  ;;(declare (type (simple-array (mod 256) char-code-max) table))
    4155  (declare (simple-string string))
    … …  
    5266        (return index))))
    5367
    54 (defun hi::%sp-reverse-find-character-with-attribute (string start end table
     68(defun %sp-reverse-find-character-with-attribute (string start end table
    5569                                                          mask)
    5670  ;;(declare (type (simple-array (mod 256) char-code-max) table))
    … …  
    6478        (return index))))
    6579
    66 (defun hi::%sp-find-character (string start end character)
     80(defun %sp-find-character (string start end character)
    6781  "%SP-Find-Character  String, Start, End, Character
    6882  Searches String for the Character from Start to End.  If the character is
    … …  
    7892      (return i))))
    7993
    80 #-clozure
    81 (defun delq (item list)
    82   (delete item list :test #'eq))
    83 
    84 #-clozure
    85 (defun memq (item list)
    86   (member item list :test #'eq))
    87 
    88 #-clozure
    89 (defun assq (item alist)
    90   (assoc item alist :test #'eq))
    91 
    9294;;;; complete-file
    9395
    94 #-CMU
    95 (progn
    96   (defun complete-file (pathname &key (defaults *default-pathname-defaults*)
    97                                       ignore-types)
    98     (let ((files (complete-file-directory pathname defaults)))
    99       (cond ((null files)
    100              (values nil nil))
    101             ((null (cdr files))
    102              (values (car files)
    103                      t))
    104             (t
    105              (let ((good-files
    106                     (delete-if #'(lambda (pathname)
    107                                    (and (simple-string-p
    108                                          (pathname-type pathname))
    109                                         (member (pathname-type pathname)
    110                                                 ignore-types
    111                                                 :test #'string=)))
    112                                files)))
    113                (cond ((null good-files))
    114                      ((null (cdr good-files))
    115                       (return-from complete-file
    116                         (values (car good-files)
    117                                 t)))
    118                      (t
    119                       (setf files good-files)))
    120                (let ((common (file-namestring (car files))))
    121                  (dolist (file (cdr files))
    122                    (let ((name (file-namestring file)))
    123                      (dotimes (i (min (length common) (length name))
     96(defun complete-file (pathname &key (defaults *default-pathname-defaults*)
     97                               ignore-types)
     98  (let ((files (complete-file-directory pathname defaults)))
     99    (cond ((null files)
     100           (values nil nil))
     101          ((null (cdr files))
     102           (values (car files)
     103                   t))
     104          (t
     105           (let ((good-files
     106                  (delete-if #'(lambda (pathname)
     107                                 (and (simple-string-p
     108                                       (pathname-type pathname))
     109                                      (member (pathname-type pathname)
     110                                              ignore-types
     111                                              :test #'string=)))
     112                             files)))
     113             (cond ((null good-files))
     114                   ((null (cdr good-files))
     115                    (return-from complete-file
     116                                 (values (car good-files)
     117                                         t)))
     118                   (t
     119                    (setf files good-files)))
     120             (let ((common (file-namestring (car files))))
     121               (dolist (file (cdr files))
     122                 (let ((name (file-namestring file)))
     123                   (dotimes (i (min (length common) (length name))
    124124                               (when (< (length name) (length common))
    125125                                 (setf common name)))
    126                        (unless (char= (schar common i) (schar name i))
    127                          (setf common (subseq common 0 i))
    128                          (return)))))
    129                  (values (merge-pathnames common pathname)
    130                          nil)))))))
     126                     (unless (char= (schar common i) (schar name i))
     127                       (setf common (subseq common 0 i))
     128                       (return)))))
     129               (values (merge-pathnames common pathname)
     130                       nil)))))))
    131131
    132132;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
    133133;;;
    134   (defun complete-file-directory (pathname defaults)
    135     (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
    136           (type (pathname-type pathname)))
    137       (setf pathname
    138             (make-pathname :defaults (truename (make-pathname :defaults pathname :name nil :type nil))
    139                           :name (pathname-name pathname)
    140                           :type type))
    141       (delete-if-not (lambda (candidate)
    142                        (search (namestring pathname) (namestring candidate)))
    143                      (append
    144                       #+CLISP
    145                       (directory
    146                        (make-pathname :defaults pathname
    147                                       :name :wild
    148                                       :type nil)) ;gosh!
    149                       #+CLISP
    150                       (directory
    151                        (make-pathname :defaults pathname
    152                                       :directory (append (pathname-directory pathname) (list "*")) ;gosh gosh!
    153                                       :name nil
    154                                       :type nil))))))
     134(defun complete-file-directory (pathname defaults)
     135  (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
     136        (type (pathname-type pathname)))
     137    (setf pathname
     138          (make-pathname :defaults (truename (make-pathname :defaults pathname :name nil :type nil))
     139                        :name (pathname-name pathname)
     140                        :type type))
     141    (delete-if-not (lambda (candidate)
     142                     (search (namestring pathname) (namestring candidate)))
     143                   (append
     144                    #+CLISP
     145                    (directory
     146                     (make-pathname :defaults pathname
     147                                    :name :wild
     148                                    :type nil)) ;gosh!
     149                    #+CLISP
     150                    (directory
     151                     (make-pathname :defaults pathname
     152                                    :directory (append (pathname-directory pathname) (list "*")) ;gosh gosh!
     153                                    :name nil
     154                                    :type nil))))))
    155155
    156156;;; Ambiguous-Files  --  Public
    157157;;;
    158   (defun ambiguous-files (pathname
    159                           &optional (defaults *default-pathname-defaults*))
    160     "Return a list of all files which are possible completions of Pathname.
     158(defun ambiguous-files (pathname
     159                        &optional (defaults *default-pathname-defaults*))
     160  "Return a list of all files which are possible completions of Pathname.
    161161   We look in the directory specified by Defaults as well as looking down
    162162   the search list."
    163     (complete-file-directory pathname defaults)) )
    164 
    165 
    166 ;;;; CLISP fixage
    167 
    168 #+CLISP
    169 (in-package :xlib)
    170 
    171 #+CLISP
    172 '(progn
    173   (defvar *lookahead* nil)
    174 
    175   (setf *buffer-read-polling-time* .01)
    176 
    177   (defun buffer-input-wait-default (display timeout)
    178     (declare (type display display)
    179              (type (or null number) timeout))
    180     (declare (values timeout))
    181 
    182     (let ((stream (display-input-stream display)))
    183       (declare (type (or null stream) stream))
    184       (cond ((null stream))
    185             ((setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) nil)
    186             ((eql timeout 0) :timeout)
    187             ((not (null timeout))
    188              (multiple-value-bind (npoll fraction)
    189                  (truncate timeout *buffer-read-polling-time*)
    190                (dotimes (i npoll)       ; Sleep for a time, then listen again
    191                  (sleep *buffer-read-polling-time*)
    192                  (when (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream)))
    193                    (return-from buffer-input-wait-default nil)))
    194                (when (plusp fraction)
    195                  (sleep fraction)       ; Sleep a fraction of a second
    196                  (when (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) ; and listen one last time
    197                    (return-from buffer-input-wait-default nil)))
    198                :timeout)))))
    199 
    200   (defun buffer-read-default (display vector start end timeout)
    201     (declare (type display display)
    202              (type buffer-bytes vector)
    203              (type array-index start end)
    204              (type (or null fixnum) timeout))
    205     ;; #.(declare-buffun)
    206     (let ((stream (display-input-stream display)))
    207       (cond ((and (eql timeout 0)
    208                   (not (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream)))) )
    209              :timeout)
    210             (t
    211              (if *lookahead*
    212                  (progn
    213                    (setf (aref vector start) *lookahead*)
    214                    (setf *lookahead* nil)
    215                    (system::read-n-bytes stream vector (+ start 1) (- end start 1)))
    216                  (system::read-n-bytes stream vector start (- end start)))
    217              nil)) ) ) )
     163  (complete-file-directory pathname defaults))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

    r7911 r7993  
    9696  came from, and sets (current-open-line) to Nil."
    9797  (when (current-open-line)
    98     (hemlock-ext:without-interrupts
     98    (without-interrupts
    9999      (let* ((open-chars (current-open-chars))
    100100             (right-pos (current-right-open-pos))
    … …  
    203203          (invoke-hook hemlock::buffer-modified-hook ,b t))
    204204        (setf (buffer-modified ,b) t))
    205       (hemlock-ext:without-interrupts ,@forms))))
     205      (without-interrupts ,@forms))))
    206206
    207207(defmacro always-change-line (mark new-line)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp

    r7844 r7993  
    9797      (let ((key-event (aref key try-pos)))
    9898        (vector-push-extend
    99          (hemlock-ext:make-key-event key-event (logior (hemlock-ext:key-event-bits key-event)
    100                                                        prefix))
     99         (make-key-event key-event (logior (key-event-bits key-event) prefix))
    101100         temp)
    102101        (setf prefix 0))
    … …  
    138137      ((or simple-vector null) entry)
    139138      (integer
    140        (cons :bits (hemlock-ext:key-event-bits-modifiers entry))))))
     139       (cons :bits (key-event-bits-modifiers entry))))))
    141140
    142141;;; %SET-KEY-TRANSLATION  --  Internal
    … …  
    144143(defun %set-key-translation (key new-value)
    145144  (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits))
    146                       (apply #'hemlock-ext:make-key-event-bits (cdr new-value)))
     145                      (apply #'make-key-event-bits (cdr new-value)))
    147146                     (new-value (crunch-key new-value))
    148147                     (t new-value))))
    … …  
    190189(defun crunch-key (key)
    191190  (typecase key
    192     (hemlock-ext:key-event (vector key))
     191    (key-event (vector key))
    193192    ((or list vector) ;List thrown in gratuitously.
    194193     (when (zerop (length key))
    195194       (error "A zero length key is illegal."))
    196      (unless (every #'hemlock-ext:key-event-p key)
     195     (unless (every #'key-event-p key)
    197196       (error "A Key ~S must contain only key-events." key))
    198197     (coerce key 'simple-vector))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp

    r7844 r7993  
    1 ;;; -*- Log: hemlock.log; Package: HEMLOCK-EXT -*-
     1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
    22;;;
    33;;; **********************************************************************
    … …  
    1010;;; **********************************************************************
    1111;;;
    12 ;;; This file implements key-events for representing editor input.  It also
    13 ;;; provides a couple routines to interface this to X11.
     12;;; This file implements key-events for representing editor input.
    1413;;;
    1514;;; Written by Blaine Burks and Bill Chiles.
    1615;;;
    1716
    18 ;;; The following are the implementation dependent parts of this code (what
    19 ;;; you would have to change if you weren't using X11):
    20 ;;;    *modifier-translations*
    21 ;;;    DEFINE-MODIFIER-BIT
    22 ;;;    TRANSLATE-KEY-EVENT
    23 ;;;    TRANSLATE-MOUSE-KEY-EVENT
    24 ;;;    DEFINE-KEYSYM
    25 ;;;    DEFINE-MOUSE-KEYSYM
    26 ;;;    DO-ALPHA-KEY-EVENTS
    27 ;;; If the window system didn't use a keysym mechanism to represent keys, you
    28 ;;; would also need to write something that mapped whatever did encode the
    29 ;;; keys to the keysyms defined with DEFINE-KEYSYM.
    30 ;;;
    31 
    32 (in-package :hemlock-ext)
    33 
     17(in-package :hemlock-internals)
     18
     19
     20
     21;;; Objects involved in key events:
     22;;; (1) a KEY-EVENT describes a combination of a KEYSYM and MODIFIERS.  KEY-EVENTS
     23;;;   are interned, so there is a unique key-event for each combination of keysym and
     24;;;   modifiers.
     25;;; (2) A KEYSYM is an object representing a key.  It must be declared to be so via
     26;;;  define-keysym.  A KEYSYM must be defined before a key-event based on it can be
     27;;;  defined.
     28;;; (3) A CODE is a system-dependent fixnum value for a KEYSYM.  It must be defined
     29;;; before any events actually occur, but it doesn't need to be defined in order to
     30;;; create key-events.
     31;;;
     32;;; The Keysym can be the same as a code, but separating them deals with a bootstrapping
     33;;; problem: keysyms cannot be defined before hemlock is loaded, but hemlock wants to
     34;;; define key events while it's loading.  So we define key events using keysyms, and let
     35;;; their codes be defined later
    3436
    3537
    … …  
    8183  (if (= (length string) 1) string (string-downcase string)))
    8284
    83 ;;; DEFINE-KEYSYM -- Public.
     85;;; DEFINE-KEYSYM -- Public
    8486;;;
    8587(defun define-keysym (keysym preferred-name &rest other-names)
    … …  
    9496
    9597;;; 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
    97 ;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
    98 ;;;
     98;;; modifier names.
     99;;;
    99100(defvar *modifier-translations*)
    100101
    … …  
    195196;;;
    196197(defun define-mouse-keysym (button keysym name shifted-bit event-key)
    197   "This defines keysym named name for the X button cross the X event-key.
    198    Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets
    199    in the key-event it returns whenever the X shift bit is on."
     198  "This defines keysym named name for the X button cross the X event-key."
    200199  (unless (<= 1 button 5)
    201200    (error "Buttons are number 1-5, not ~D." button))
    … …  
    216215                      (:constructor %make-key-event (keysym bits)))
    217216  (bits nil :type fixnum)
    218   (keysym nil :type fixnum))
     217  (keysym nil))
    219218
    220219(defun %print-key-event (object stream ignore)
    221220  (declare (ignore ignore))
    222221  (write-string "#<Key-Event " stream)
    223   (print-pretty-key-event object stream)
     222  (print-pretty-key object stream)
    224223  (write-char #\> stream))
    225224
    … …  
    227226;;; syntax.
    228227;;;
    229 (defvar *key-character-classes* (make-array char-code-limit
     228(defvar *key-character-classes* (make-array hemlock-char-code-limit
    230229                                            :initial-element :other))
    231230
    … …  
    262261;;; form.  Since key-events are unique at runtime, we cannot create them at
    263262;;; readtime, returning the constant object from READ.  Wherever a #k appears,
    264 ;;; there's a for that at loadtime or runtime will return the unique key-event
     263;;; there's a form that at loadtime or runtime will return the unique key-event
    265264;;; or vector of unique key-events.
    266265;;;
    … …  
    274273          (error "Keys must be delimited by ~S." #\"))
    275274        ;; Skip any leading spaces in the string.
    276         (skip-whitespace stream)
     275        (peek-char t stream)
    277276        (multiple-value-setq (char class) (get-key-char stream))
    278277        (ecase class
    … …  
    297296        (setf bits 0)
    298297        ;; Skip any whitespace between characters.
    299         (skip-whitespace stream)
     298        (peek-char t stream)
    300299        (multiple-value-setq (char class) (get-key-char stream))
    301300        (ecase class
    … …  
    374373  "A list of all the names of defined modifiers.")
    375374
    376 ;;; DEFINE-KEY-EVENT-MODIFIER -- Public.
    377 ;;;
    378375;;; Note that short-name is pushed into *modifiers-to-internal-masks* after
    379376;;; long-name.  PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on
    … …  
    415412;;;
    416413(defun define-modifier-bit (bit-mask modifier-name)
    417   "This establishes a mapping from bit-mask to a define key-event modifier-name.
    418    TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events
    419    with bits defined by this routine."
     414  "This establishes a mapping from bit-mask to a define key-event modifier-name."
    420415  (let ((map (assoc modifier-name *modifiers-to-internal-masks*
    421416                    :test #'string-equal)))
    … …  
    429424;;;
    430425
    431 ;;; MAKE-KEY-EVENT-BITS -- Public.
    432 ;;;
    433426(defun make-key-event-bits (&rest modifier-names)
    434427  "This returns bits suitable for MAKE-KEY-EVENT from the supplied modifier
    … …  
    468461;;;; Key event lookup -- GET-KEY-EVENT and MAKE-KEY-EVENT.
    469462
    470 (defvar *keysym-high-bytes*)
    471 
    472 (defconstant modifier-bits-limit (ash 1 modifier-count-limit))
     463(defvar *key-events*)
    473464
    474465;;; GET-KEY-EVENT -- Internal.
    … …  
    480471;;;
    481472(defun get-key-event* (keysym bits)
    482   (let* ((char (code-char keysym)))
     473  (let* ((char (and (fixnump keysym) (code-char keysym))))
    483474    (when (and char (standard-char-p char))
    484475      (let* ((mask (key-event-modifier-mask "Shift")))
    … …  
    486477          (setq bits (logandc2 bits mask)
    487478                keysym (char-code (char-upcase char)))))))
    488   (let* ((high-byte (ash keysym -8))
    489          (low-byte-vector (svref *keysym-high-bytes* high-byte)))
    490     (unless low-byte-vector
    491       (let ((new-vector (make-array 256 :initial-element nil)))
    492         (setf (svref *keysym-high-bytes* high-byte) new-vector)
    493         (setf low-byte-vector new-vector)))
    494     (let* ((low-byte (ldb (byte 8 0) keysym))
    495            (bit-vector (svref low-byte-vector low-byte)))
    496       (unless bit-vector
    497         (let ((new-vector (make-array modifier-bits-limit
    498                                       :initial-element nil)))
    499           (setf (svref low-byte-vector low-byte) new-vector)
    500           (setf bit-vector new-vector)))
    501       (let ((key-event (svref bit-vector bits)))
    502         (if key-event
    503             key-event
    504             (setf (svref bit-vector bits) (%make-key-event keysym bits)))))))
    505 
    506 ;;; MAKE-KEY-EVENT --  Public.
     479  (let* ((data (cons keysym bits)))
     480    (or (gethash data *key-events*)
     481        (setf (gethash data *key-events*) (%make-key-event keysym bits)))))
     482
     483;;;
     484(defvar *keysym-to-code*)
     485(defvar *code-to-keysym*)
     486
     487(defmacro define-keysym-code (keysym code)
     488  `(progn
     489     (setf (gethash ,keysym *keysym-to-code*) ,code)
     490     (setf (gethash ,code *code-to-keysym*) ,keysym)))
     491
     492(defun keysym-for-code (code)
     493  (or (gethash code *code-to-keysym*) code))
     494
     495(defun code-for-keysym (keysym)
     496  (or (gethash keysym *keysym-to-code*) (and (fixnump keysym) keysym)))
     497
    507498;;;
    508499(defun make-key-event (object &optional (bits 0))
    … …  
    513504  (etypecase object
    514505    (integer
    515      (unless (keysym-names object)
    516        (error "~S is an undefined keysym." object))
    517      (get-key-event* object bits))
     506     (let ((keysym (keysym-for-code object)))
     507       (unless (keysym-names keysym)
     508         (error "~S is an undefined code." object))
     509       (get-key-event* keysym bits)))
    518510    #|(character
    519511     (let* ((name (char-name object))
    … …  
    555547  (check-type key-event key-event)
    556548  (or (gethash key-event *key-event-characters*)
    557       (code-char (key-event-keysym key-event))))
     549      (code-char (code-for-keysym (key-event-keysym key-event)))))
    558550
    559551(defun %set-key-event-char (key-event character)
    … …  
    618610;;;; PRINT-PRETTY-KEY and PRINT-PRETTY-KEY-EVENT.
    619611
    620 ;;; PRINT-PRETTY-KEY -- Public.
     612;;; PRINT-PRETTY-KEY -- Internal
    621613;;;
    622614(defun print-pretty-key (key &optional (stream *standard-output*) long-names-p)
    … …  
    624616   user-expected fashion.  Long-names-p indicates whether modifiers should
    625617   print with their long or short name."
    626   (declare (type (or vector key-event) key) (type stream stream))
    627618  (etypecase key
    628619    (key-event (print-pretty-key-event key stream long-names-p))
    … …  
    634625           (unless (= i length-1) (write-char #\space stream))))))))
    635626
    636 ;;; PRINT-PRETTY-KEY-EVENT -- Public.
     627;;; PRINT-PRETTY-KEY-EVENT -- Internal
    637628;;;
    638629;;; Note, this makes use of the ordering in the a-list
    … …  
    658649    (when spacep (write-char #\> stream))))
    659650
    660 
     651;;; PRETTY-KEY-STRING - Public.
     652;;;
     653(defun pretty-key-string (key &optional long-names-p)
     654  (with-output-to-string (s)
     655    (print-pretty-key key s long-names-p)))
    661656
    662657
    … …  
    676671  (setf *keysyms-to-names* (make-hash-table :test #'eql))
    677672  (setf *names-to-keysyms* (make-hash-table :test #'equal))
     673  (setf *keysym-to-code* (make-hash-table :test #'eql))
     674  (setf *code-to-keysym* (make-hash-table :test #'eql))
    678675  (setf *modifier-translations* ())
    679676  (setf *modifiers-to-internal-masks* ())
    … …  
    681678  (setf *modifier-count* 0)
    682679  (setf *all-modifier-names* ())
    683   (setf *keysym-high-bytes* (make-array 256 :initial-element nil))
     680  (setf *key-events* (make-hash-table :test #'equal))
    684681  (setf *key-event-characters* (make-hash-table))
    685682  (setf *character-key-events*
    686         (make-array char-code-limit :initial-element nil))
     683        (make-array hemlock-char-code-limit :initial-element nil))
    687684 
    688685  (define-key-event-modifier "Hyper" "H")

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/keysym-defs.lisp

    r6999 r7993  
    1010;;; **********************************************************************
    1111;;;
    12 ;;; This file defines all the definitions of keysyms (see key-event.lisp).
    13 ;;; These keysyms match those for X11.
    1412;;;
    1513;;; Written by Bill Chiles
    1614;;; Modified by Blaine Burks.
    1715;;;
     16;;; This file defines all the "portable" keysyms.
    1817
    1918(in-package :hemlock-internals)
    2019
     20;;; "Named" keys.
     21;;;
     22(define-keysym 9 "Tab")
     23(define-keysym 27 "Escape" "Altmode" "Alt")             ;escape
     24(define-keysym 127 "Delete" "Backspace")  ;backspace
     25(define-keysym 13 "Return" "Newline")
     26(define-keysym 10 "LineFeed")
     27(define-keysym 3 "Enter")
     28(define-keysym 32 "Space" " ")
     29
     30;;; Letters.
     31;;;
     32(define-keysym 97 "a") (define-keysym 65 "A")
     33(define-keysym 98 "b") (define-keysym 66 "B")
     34(define-keysym 99 "c") (define-keysym 67 "C")
     35(define-keysym 100 "d") (define-keysym 68 "D")
     36(define-keysym 101 "e") (define-keysym 69 "E")
     37(define-keysym 102 "f") (define-keysym 70 "F")
     38(define-keysym 103 "g") (define-keysym 71 "G")
     39(define-keysym 104 "h") (define-keysym 72 "H")
     40(define-keysym 105 "i") (define-keysym 73 "I")
     41(define-keysym 106 "j") (define-keysym 74 "J")
     42(define-keysym 107 "k") (define-keysym 75 "K")
     43(define-keysym 108 "l") (define-keysym 76 "L")
     44(define-keysym 109 "m") (define-keysym 77 "M")
     45(define-keysym 110 "n") (define-keysym 78 "N")
     46(define-keysym 111 "o") (define-keysym 79 "O")
     47(define-keysym 112 "p") (define-keysym 80 "P")
     48(define-keysym 113 "q") (define-keysym 81 "Q")
     49(define-keysym 114 "r") (define-keysym 82 "R")
     50(define-keysym 115 "s") (define-keysym 83 "S")
     51(define-keysym 116 "t") (define-keysym 84 "T")
     52(define-keysym 117 "u") (define-keysym 85 "U")
     53(define-keysym 118 "v") (define-keysym 86 "V")
     54(define-keysym 119 "w") (define-keysym 87 "W")
     55(define-keysym 120 "x") (define-keysym 88 "X")
     56(define-keysym 121 "y") (define-keysym 89 "Y")
     57(define-keysym 122 "z") (define-keysym 90 "Z")
     58
     59;;; Standard number keys.
     60;;;
     61(define-keysym 49 "1") (define-keysym 33 "!")
     62(define-keysym 50 "2") (define-keysym 64 "@")
     63(define-keysym 51 "3") (define-keysym 35 "#")
     64(define-keysym 52 "4") (define-keysym 36 "$")
     65(define-keysym 53 "5") (define-keysym 37 "%")
     66(define-keysym 54 "6") (define-keysym 94 "^")
     67(define-keysym 55 "7") (define-keysym 38 "&")
     68(define-keysym 56 "8") (define-keysym 42 "*")
     69(define-keysym 57 "9") (define-keysym 40 "(")
     70(define-keysym 48 "0") (define-keysym 41 ")")
     71
     72;;; "Standard" symbol keys.
     73;;;
     74(define-keysym 96 "`") (define-keysym 126 "~")
     75(define-keysym 45 "-") (define-keysym 95 "_")
     76(define-keysym 61 "=") (define-keysym 43 "+")
     77(define-keysym 91 "[") (define-keysym 123 "{")
     78(define-keysym 93 "]") (define-keysym 125 "}")
     79(define-keysym 92 "\\") (define-keysym 124 "|")
     80(define-keysym 59 ";") (define-keysym 58 ":")
     81(define-keysym 39 "'") (define-keysym 34 "\"")
     82(define-keysym 44 ",") (define-keysym 60 "<")
     83(define-keysym 46 ".") (define-keysym 62 ">")
     84(define-keysym 47 "/") (define-keysym 63 "?")
    2185
    2286
    23 
    24 ;;; Function keys for the RT.
    25 ;;;
    26 
    27 ;;; This isn't the RT.
    28 (eval-when (:compile-toplevel :execute)
    29   (ccl::use-interface-dir :cocoa))
    30 
    31 (hemlock-ext:define-keysym #$NSF1FunctionKey "F1")
    32 (hemlock-ext:define-keysym #$NSF2FunctionKey "F2")
    33 (hemlock-ext:define-keysym #$NSF3FunctionKey "F3")
    34 (hemlock-ext:define-keysym #$NSF4FunctionKey "F4")
    35 (hemlock-ext:define-keysym #$NSF5FunctionKey "F5")
    36 (hemlock-ext:define-keysym #$NSF6FunctionKey "F6")
    37 (hemlock-ext:define-keysym #$NSF7FunctionKey "F7")
    38 (hemlock-ext:define-keysym #$NSF8FunctionKey "F8")
    39 (hemlock-ext:define-keysym #$NSF9FunctionKey "F9")
    40 (hemlock-ext:define-keysym #$NSF10FunctionKey "F10")
    41 (hemlock-ext:define-keysym #$NSF11FunctionKey "F11")
    42 (hemlock-ext:define-keysym #$NSF12FunctionKey "F12")
    43 (hemlock-ext:define-keysym #$NSF13FunctionKey "F13")
    44 (hemlock-ext:define-keysym #$NSF14FunctionKey "F14")
    45 (hemlock-ext:define-keysym #$NSF15FunctionKey "F15")
    46 (hemlock-ext:define-keysym #$NSF16FunctionKey "F16")
    47 (hemlock-ext:define-keysym #$NSF17FunctionKey "F17")
    48 (hemlock-ext:define-keysym #$NSF18FunctionKey "F18")
    49 (hemlock-ext:define-keysym #$NSF19FunctionKey "F19")
    50 (hemlock-ext:define-keysym #$NSF20FunctionKey "F20")
    51 (hemlock-ext:define-keysym #$NSF21FunctionKey "F21")
    52 (hemlock-ext:define-keysym #$NSF22FunctionKey "F22")
    53 (hemlock-ext:define-keysym #$NSF23FunctionKey "F23")
    54 (hemlock-ext:define-keysym #$NSF24FunctionKey "F24")
    55 (hemlock-ext:define-keysym #$NSF25FunctionKey "F25")
    56 (hemlock-ext:define-keysym #$NSF26FunctionKey "F26")
    57 (hemlock-ext:define-keysym #$NSF27FunctionKey "F27")
    58 (hemlock-ext:define-keysym #$NSF28FunctionKey "F28")
    59 (hemlock-ext:define-keysym #$NSF29FunctionKey "F29")
    60 (hemlock-ext:define-keysym #$NSF30FunctionKey "F30")
    61 (hemlock-ext:define-keysym #$NSF31FunctionKey "F31")
    62 (hemlock-ext:define-keysym #$NSF32FunctionKey "F32")
    63 (hemlock-ext:define-keysym #$NSF33FunctionKey "F33")
    64 (hemlock-ext:define-keysym #$NSF34FunctionKey "F34")
    65 (hemlock-ext:define-keysym #$NSF35FunctionKey "F35")
    66 
     87(define-keysym :F1 "F1")
     88(define-keysym :F2 "F2")
     89(define-keysym :F3 "F3")
     90(define-keysym :F4 "F4")
     91(define-keysym :F5 "F5")
     92(define-keysym :F6 "F6")
     93(define-keysym :F7 "F7")
     94(define-keysym :F8 "F8")
     95(define-keysym :F9 "F9")
     96(define-keysym :F10 "F10")
     97(define-keysym :F11 "F11")
     98(define-keysym :F12 "F12")
     99(define-keysym :F13 "F13")
     100(define-keysym :F14 "F14")
     101(define-keysym :F15 "F15")
     102(define-keysym :F16 "F16")
     103(define-keysym :F17 "F17")
     104(define-keysym :F18 "F18")
     105(define-keysym :F19 "F19")
     106(define-keysym :F20 "F20")
     107(define-keysym :F21 "F21")
     108(define-keysym :F22 "F22")
     109(define-keysym :F23 "F23")
     110(define-keysym :F24 "F24")
     111(define-keysym :F25 "F25")
     112(define-keysym :F26 "F26")
     113(define-keysym :F27 "F27")
     114(define-keysym :F28 "F28")
     115(define-keysym :F29 "F29")
     116(define-keysym :F30 "F30")
     117(define-keysym :F31 "F31")
     118(define-keysym :F32 "F32")
     119(define-keysym :F33 "F33")
     120(define-keysym :F34 "F34")
     121(define-keysym :F35 "F35")
    67122
    68123;;; Upper right key bank.
    69124;;;
    70 (hemlock-ext:define-keysym #$NSPrintScreenFunctionKey "Printscreen")
     125(define-keysym :printscreen "Printscreen")
    71126;; Couldn't type scroll lock.
    72 (hemlock-ext:define-keysym #$NSPauseFunctionKey "Pause")
     127(define-keysym :pause "Pause")
    73128
    74129;;; Middle right key bank.
    75130;;;
    76 (hemlock-ext:define-keysym #$NSInsertFunctionKey "Insert")
    77 (hemlock-ext:define-keysym #$NSDeleteFunctionKey "Del" "Rubout" (string (code-char 127)))
    78 (hemlock-ext:define-keysym #$NSHomeFunctionKey "Home")
    79 (hemlock-ext:define-keysym #$NSPageUpFunctionKey "Pageup")
    80 (hemlock-ext:define-keysym #$NSEndFunctionKey "End")
    81 (hemlock-ext:define-keysym #$NSPageDownFunctionKey "Pagedown")
     131(define-keysym :insert "Insert")
     132(define-keysym :del "Del" "Rubout" (string (code-char 127)))
     133(define-keysym :home "Home")
     134(define-keysym :pageup "Pageup")
     135(define-keysym :end "End")
     136(define-keysym :pagedown "Pagedown")
    82137
    83138;;; Arrows.
    84139;;;
    85 (hemlock-ext:define-keysym #$NSLeftArrowFunctionKey "Leftarrow")
    86 (hemlock-ext:define-keysym #$NSUpArrowFunctionKey "Uparrow")
    87 (hemlock-ext:define-keysym #$NSDownArrowFunctionKey "Downarrow")
    88 (hemlock-ext:define-keysym #$NSRightArrowFunctionKey "Rightarrow")
     140(define-keysym :leftarrow "Leftarrow")
     141(define-keysym :uparrow "Uparrow")
     142(define-keysym :downarrow "Downarrow")
     143(define-keysym :rightarrow "Rightarrow")
    89144
    90145
    91 ;;; "Named" keys.
    92 ;;;
    93 (hemlock-ext:define-keysym 9 "Tab")
    94 (hemlock-ext:define-keysym 27 "Escape" "Altmode" "Alt")         ;escape
    95 (hemlock-ext:define-keysym 127 "Delete" "Backspace")                            ;backspace
    96 (hemlock-ext:define-keysym 13 "Return" "Newline")
    97 (hemlock-ext:define-keysym 10 "LineFeed")
    98 (hemlock-ext:define-keysym 3 "Enter")
    99 (hemlock-ext:define-keysym 32 "Space" " ")
    100 
    101 ;;; Letters.
    102 ;;;
    103 (hemlock-ext:define-keysym 97 "a") (hemlock-ext:define-keysym 65 "A")
    104 (hemlock-ext:define-keysym 98 "b") (hemlock-ext:define-keysym 66 "B")
    105 (hemlock-ext:define-keysym 99 "c") (hemlock-ext:define-keysym 67 "C")
    106 (hemlock-ext:define-keysym 100 "d") (hemlock-ext:define-keysym 68 "D")
    107 (hemlock-ext:define-keysym 101 "e") (hemlock-ext:define-keysym 69 "E")
    108 (hemlock-ext:define-keysym 102 "f") (hemlock-ext:define-keysym 70 "F")
    109 (hemlock-ext:define-keysym 103 "g") (hemlock-ext:define-keysym 71 "G")
    110 (hemlock-ext:define-keysym 104 "h") (hemlock-ext:define-keysym 72 "H")
    111 (hemlock-ext:define-keysym 105 "i") (hemlock-ext:define-keysym 73 "I")
    112 (hemlock-ext:define-keysym 106 "j") (hemlock-ext:define-keysym 74 "J")
    113 (hemlock-ext:define-keysym 107 "k") (hemlock-ext:define-keysym 75 "K")
    114 (hemlock-ext:define-keysym 108 "l") (hemlock-ext:define-keysym 76 "L")
    115 (hemlock-ext:define-keysym 109 "m") (hemlock-ext:define-keysym 77 "M")
    116 (hemlock-ext:define-keysym 110 "n") (hemlock-ext:define-keysym 78 "N")
    117 (hemlock-ext:define-keysym 111 "o") (hemlock-ext:define-keysym 79 "O")
    118 (hemlock-ext:define-keysym 112 "p") (hemlock-ext:define-keysym 80 "P")
    119 (hemlock-ext:define-keysym 113 "q") (hemlock-ext:define-keysym 81 "Q")
    120 (hemlock-ext:define-keysym 114 "r") (hemlock-ext:define-keysym 82 "R")
    121 (hemlock-ext:define-keysym 115 "s") (hemlock-ext:define-keysym 83 "S")
    122 (hemlock-ext:define-keysym 116 "t") (hemlock-ext:define-keysym 84 "T")
    123 (hemlock-ext:define-keysym 117 "u") (hemlock-ext:define-keysym 85 "U")
    124 (hemlock-ext:define-keysym 118 "v") (hemlock-ext:define-keysym 86 "V")
    125 (hemlock-ext:define-keysym 119 "w") (hemlock-ext:define-keysym 87 "W")
    126 (hemlock-ext:define-keysym 120 "x") (hemlock-ext:define-keysym 88 "X")
    127 (hemlock-ext:define-keysym 121 "y") (hemlock-ext:define-keysym 89 "Y")
    128 (hemlock-ext:define-keysym 122 "z") (hemlock-ext:define-keysym 90 "Z")
    129 
    130 ;;; Standard number keys.
    131 ;;;
    132 (hemlock-ext:define-keysym 49 "1") (hemlock-ext:define-keysym 33 "!")
    133 (hemlock-ext:define-keysym 50 "2") (hemlock-ext:define-keysym 64 "@")
    134 (hemlock-ext:define-keysym 51 "3") (hemlock-ext:define-keysym 35 "#")
    135 (hemlock-ext:define-keysym 52 "4") (hemlock-ext:define-keysym 36 "$")
    136 (hemlock-ext:define-keysym 53 "5") (hemlock-ext:define-keysym 37 "%")
    137 (hemlock-ext:define-keysym 54 "6") (hemlock-ext:define-keysym 94 "^")
    138 (hemlock-ext:define-keysym 55 "7") (hemlock-ext:define-keysym 38 "&")
    139 (hemlock-ext:define-keysym 56 "8") (hemlock-ext:define-keysym 42 "*")
    140 (hemlock-ext:define-keysym 57 "9") (hemlock-ext:define-keysym 40 "(")
    141 (hemlock-ext:define-keysym 48 "0") (hemlock-ext:define-keysym 41 ")")
    142 
    143 ;;; "Standard" symbol keys.
    144 ;;;
    145 (hemlock-ext:define-keysym 96 "`") (hemlock-ext:define-keysym 126 "~")
    146 (hemlock-ext:define-keysym 45 "-") (hemlock-ext:define-keysym 95 "_")
    147 (hemlock-ext:define-keysym 61 "=") (hemlock-ext:define-keysym 43 "+")
    148 (hemlock-ext:define-keysym 91 "[") (hemlock-ext:define-keysym 123 "{")
    149 (hemlock-ext:define-keysym 93 "]") (hemlock-ext:define-keysym 125 "}")
    150 (hemlock-ext:define-keysym 92 "\\") (hemlock-ext:define-keysym 124 "|")
    151 (hemlock-ext:define-keysym 59 ";") (hemlock-ext:define-keysym 58 ":")
    152 (hemlock-ext:define-keysym 39 "'") (hemlock-ext:define-keysym 34 "\"")
    153 (hemlock-ext:define-keysym 44 ",") (hemlock-ext:define-keysym 60 "<")
    154 (hemlock-ext:define-keysym 46 ".") (hemlock-ext:define-keysym 62 ">")
    155 (hemlock-ext:define-keysym 47 "/") (hemlock-ext:define-keysym 63 "?")
    156 
    157 
    158 (hemlock-ext::define-mouse-keysym 1 #xe000 "Leftdown" "Super" :button-press)
    159 
    160 ;;;
    161 
    162 ;(hemlock-ext:define-keysym 65290 "linefeed")
    163 
    164 
     146(define-mouse-keysym 1 #xe000 "Leftdown" "Super" :button-press)
    165147
    166148
    … …  
    184166(let ((@-code (char-code #\@)))
    185167  (dotimes (i (char-code #\space))
    186     (setf (hemlock-ext:char-key-event (code-char i))
    187           (hemlock-ext::make-key-event (string (char-downcase (code-char (+ i @-code))))
    188                                (hemlock-ext:key-event-modifier-mask "control")))))
    189 (setf (hemlock-ext:char-key-event (code-char 9)) (hemlock-ext::make-key-event #k"Tab"))
    190 (setf (hemlock-ext:char-key-event (code-char 10)) (hemlock-ext::make-key-event #k"Linefeed"))
    191 (setf (hemlock-ext:char-key-event (code-char 13)) (hemlock-ext::make-key-event #k"Return"))
    192 (setf (hemlock-ext:char-key-event (code-char 27)) (hemlock-ext::make-key-event #k"Alt"))
    193 (setf (hemlock-ext:char-key-event (code-char 8)) (hemlock-ext::make-key-event #k"Backspace"))
     168    (setf (char-key-event (code-char i))
     169          (make-key-event (string (char-downcase (code-char (+ i @-code))))
     170                          (key-event-modifier-mask "control")))))
     171(setf (char-key-event (code-char 9)) (make-key-event #k"Tab"))
     172(setf (char-key-event (code-char 10)) (make-key-event #k"Linefeed"))
     173(setf (char-key-event (code-char 13)) (make-key-event #k"Return"))
     174(setf (char-key-event (code-char 27)) (make-key-event #k"Alt"))
     175(setf (char-key-event (code-char 8)) (make-key-event #k"Backspace"))
    194176;;;
    195177;;; Other ASCII codes are exactly the same as the Common Lisp codes.
    … …  
    197179(do ((i (char-code #\space) (1+ i)))
    198180    ((= i 128))
    199   (setf (hemlock-ext:char-key-event (code-char i))
    200         (hemlock-ext::make-key-event (string (code-char i)))))
     181  (setf (char-key-event (code-char i))
     182        (make-key-event (string (code-char i)))))
    201183
    202184;;; This makes KEY-EVENT-CHAR the inverse of CHAR-KEY-EVENT from the start.
    … …  
    205187(dotimes (i 128)
    206188  (let ((character (code-char i)))
    207     (setf (hemlock-ext::key-event-char (hemlock-ext:char-key-event character)) character)))
     189    (setf (key-event-char (char-key-event character)) character)))
    208190
    209191;;; Since we treated these characters specially above when setting
    210 ;;; HEMLOCK-EXT:CHAR-KEY-EVENT above, we must set these HEMLOCK-EXT:KEY-EVENT-CHAR's specially
     192;;; CHAR-KEY-EVENT above, we must set these KEY-EVENT-CHAR's specially
    211193;;; to make quoting characters into Hemlock buffers more obvious for users.
    212194;;;
    213 (setf (hemlock-ext:key-event-char #k"C-h") #\backspace)
    214 (setf (hemlock-ext:key-event-char #k"C-i") #\tab)
    215 (setf (hemlock-ext:key-event-char #k"C-j") #\linefeed)
    216 (setf (hemlock-ext:key-event-char #k"C-m") #\return)
     195(setf (key-event-char #k"C-h") #\backspace)
     196(setf (key-event-char #k"C-i") #\tab)
     197(setf (key-event-char #k"C-j") #\linefeed)
     198(setf (key-event-char #k"C-m") #\return)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

    r7919 r7993  
    7878
    7979(defmacro with-buffer-bindings ((buffer) &body body)
    80   (let ((buffer-var (gensym)))
    81     `(let ((,buffer-var ,buffer)
    82            ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var))))
     80  (let ((buffer-var (gensym))
     81        (setup-p (gensym)))
     82    `(let* ((,buffer-var ,buffer)
     83            (,setup-p nil)
     84            ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var))))
    8385       (unwind-protect
    8486           (progn
    85              (setup-buffer-bindings ,buffer-var)
     87             (unless (buffer-bindings-wound-p ,buffer-var)
     88               (setup-buffer-bindings ,buffer-var)
     89               (setq ,setup-p t))
    8690             ,@body)
    87          (revert-buffer-bindings ,buffer-var)))))
     91       (when ,setup-p (revert-buffer-bindings ,buffer-var))))))
    8892
    8993
    … …  
    418422        )
    419423   Each tag is either a character or a logical key-event.  The user's typed
    420    key-event is compared using either EXT:LOGICAL-KEY-EVENT-P or CHAR= of
    421    EXT:KEY-EVENT-CHAR.
     424   key-event is compared using either LOGICAL-KEY-EVENT-P or CHAR= of
     425   KEY-EVENT-CHAR.
    422426
    423427   The legal keys of the key/value pairs are :help, :prompt, and :bind."
    … …  
    436440                         (setf ,',bind
    437441                               (prompt-for-key-event :prompt ,',n-prompt))
    438                          (setf ,',bind-char (hemlock-ext:key-event-char ,',bind))
     442                         (setf ,',bind-char (key-event-char ,',bind))
    439443                         (go ,',again))))
    440444           (block ,bname
    441445             (let* ((,n-prompt ,prompt)
    442446                    (,bind (prompt-for-key-event :prompt ,n-prompt))
    443                     (,bind-char (hemlock-ext:key-event-char ,bind)))
     447                    (,bind-char (key-event-char ,bind)))
    444448               (declare (ignorable,bind ,bind-char))
    445449               (tagbody

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp

    r7844 r7993  
    1616
    1717(in-package :hemlock-internals)
    18 
    19 #||
    20 GB
    21 (in-package :extensions)
    22 (export '(save-all-buffers *hemlock-version*))
    23 (in-package :hemlock-internals)
    24 ||#
    25 
    26 
    27 
    2818
    2919;;;; Definition of *hemlock-version*.

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp

    r7929 r7993  
    102102                   (let ((val (variable-value 'hemlock::current-package
    103103                                              :buffer buffer)))
    104                      (if val
     104                     (if (stringp val)
    105105                       (if (find-package val)
    106106                         (format nil "~A:  " val)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp

    r7934 r7993  
    210210             :help "Name of command to bind to a key."))
    211211    (values (prompt-for-key
    212              :prompt "Bind to: "  :must-exist nil
     212             :must-exist nil
     213             :prompt "Bind to: "
    213214             :help "Key to bind command to, confirm to complete."))
    214215    (prompt-for-place "Kind of binding: "
    215                       "The kind of binding to make.")))             
     216                      "The kind of binding to make.")))
    216217
    217218(defcommand "Delete Key Binding" (p)
    … …  
    221222  (declare (ignore p))
    222223  (let ((key (prompt-for-key
    223               :prompt "Delete binding: " :must-exist nil
     224              :must-exist nil
     225              :prompt "Delete binding: "
    224226              :help "Key to delete binding from.")))
    225227    (multiple-value-bind (kind where)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

    r7933 r7993  
    11(in-package :cl-user)
    2 
    3 ;; Note: I want real relative package names like the Symbolics has
    4 ;; them. In the mean time:
    5 
    6 #+CMU
    7 (eval-when (:compile-toplevel :load-toplevel :execute)
    8   (progn
    9     ;; Just in case the original Hemlock is loaded.
    10     (dolist (p '("HEMLOCK" "HEMLOCK-INTERNALS"))
    11       (when (find-package p)
    12         (delete-package p)))))
    13    
    142
    153(defpackage :hemlock-interface
    … …  
    301289   ))
    302290
     291;; Functions defined externally (i.e. used by but not defined in hemlock).  In theory,
     292;; these (and codes for the symbolic keysyms in keysym-defs.lisp, q.v.) is all you need
     293;; to implement to port the IDE to a different window system.
    303294(defpackage :hemlock-ext
    304   (:use :common-lisp
    305         :hemlock-interface)
    306   #+cmu
    307   (:import-from :ext #:complete-file)
    308   (:shadow #:char-code-limit)
    309   #+clozure
    310   (:import-from :ccl #:memq #:assq #:delq)
    311   #+clozure
    312   (:import-from :gui #:log-debug)
     295  (:use)
    313296  ;;
    314297  (:export
    315    #:file-comment
    316    #:without-interrupts
    317    #:define-setf-method
    318    #:getenv
    319    #:delq #:memq #:assq
    320    #:fixnump
    321    #:file-writable
    322      
    323    ;; key-event.lisp
    324    #:define-keysym
    325    #:define-mouse-keysym
    326    #:name-keysym
    327    #:keysym-names
    328    #:keysym-preferred-name
    329    #:define-key-event-modifier
    330    #:define-modifier-bit
    331    #:make-key-event-bits
    332    #:key-event-modifier-mask
    333    #:key-event-bits-modifiers
    334    #:*all-modifier-names*
    335    #:translate-key-event
    336    #:translate-mouse-key-event
    337    #:make-key-event
    338    #:key-event
    339    #:key-event-p
    340    #:key-event-bits
    341    #:key-event-keysym
    342    #:char-key-event
    343    #:key-event-char
    344    #:key-event-bit-p
    345    #:do-alpha-key-events
    346    #:print-pretty-key
    347    #:print-pretty-key-event
    348 
    349    ;; hemlock-ext.lisp
    350    #:complete-file
    351    #:default-directory
    352 
    353    ;; defined externally (i.e. used by but not defined in hemlock).  These are the
    354    ;; things that would need to be implemented to port to a different window system.
    355298   #:invoke-modifying-buffer-storage
    356299   #:note-selection-set-by-search
    … …  
    374317  (:use :common-lisp :hemlock-interface)
    375318  (:nicknames :hemlock-internals)
    376   (:shadow #:char-code-limit)
    377319  (:import-from
    378320   ;; gray streams
    … …  
    384326   #+clozure :gray
    385327   ;;
    386    ;; Note the pacth i received from DTC mentions character-output and
     328   ;; Note the patch i received from DTC mentions character-output and
    387329   ;; character-input-stream here, so we actually see us faced to
    388330   ;; provide for compatibility classes. --GB
    … …  
    402344   #:stream-force-output
    403345   #:stream-line-column)
    404   (:import-from :hemlock-ext
     346  (:import-from :ccl
    405347                #:delq #:memq #:assq
    406                 #+clozure #:log-debug)
     348                #:getenv
     349                #:fixnump)
     350  (:import-from :gui
     351                #:log-debug)
     352  ;; ** TODO: get rid of this.  The code that uses it assumes it guarantees atomicity,
     353  ;; and it doesn't.
     354  (:import-from :ccl #:without-interrupts)
    407355  ;;
    408356  (:export
    409357   #:*FAST*                             ;hmm not sure about this one
    410358   
     359   ;; Imported
     360   #:delq #:memq #:assq #:getenv #:fixnump #:log-debug
     361
     362   ;; hemlock-ext.lisp
     363   #:hemlock-char-code-limit
     364   #:file-writable #:default-directory #:complete-file #:ambiguous-files
     365
    411366   ;; rompsite.lisp
    412367   #:show-mark #:fun-defined-from-pathname
    … …  
    443398   #:hemlock-view #:current-view #:hemlock-view-buffer
    444399   #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed
     400   #:invoke-command
    445401   #:abort-to-toplevel #:abort-current-command
    446402   #:set-scroll-position
    … …  
    477433   ;; charmacs.lisp
    478434   #:syntax-char-code-limit #:search-char-code-limit #:do-alpha-chars
     435
     436   ;; key-event.lisp
     437   #:define-keysym-code #:define-mouse-keysym #:define-modifier-bit
     438   #:*all-modifier-names* #:*modifier-translations*
     439   #:make-key-event #:char-key-event #:do-alpha-key-events
     440   #:key-event-modifier-mask #:key-event-char #:key-event-bit-p
     441   #:pretty-key-string
    479442
    480443   ;; display.lisp
    … …  
    491454   #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string
    492455   #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n
    493    #:prompt-for-key-event #:prompt-for-key #:prompt-for-command-key
     456   #:prompt-for-key-event #:prompt-for-key
    494457   #:*logical-key-event-names*
    495458   #:logical-key-event-p #:logical-key-event-documentation
    … …  
    541504   #:bind-key #:delete-key-binding #:get-command #:map-bindings
    542505   #:make-command #:command-name #:command-bindings #:last-command-type
    543    #:prefix-argument #:*invoke-hook* #:key-translation
     506   #:prefix-argument #:key-translation
    544507
    545508
    … …  
    586549(defpackage :hemlock
    587550  (:use :common-lisp :hemlock-interface :hemlock-internals :hemlock-ext)
    588   (:shadowing-import-from :hemlock-ext
    589                           #:char-code-limit)
    590   #+clozure (:import-from :hemlock-ext #:log-debug)
    591551  )
    592552

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp

    r7913 r7993  
    137137    (do-registers (name val :sorted)
    138138      (write-string "Reg " f)
    139       (hemlock-ext:print-pretty-key-event name f)
     139      (write-string (pretty-key-string name) f)
    140140      (write-string ":  " f)
    141141      (etypecase val

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp

    r7844 r7993  
    4848  is a function which is called with each object that falls off the
    4949  end."
    50   (unless (and (hemlock-ext:fixnump size) (> size 0))
     50  (unless (and (fixnump size) (> size 0))
    5151    (error "Ring size, ~S is not a positive fixnum." size))
    5252  (internal-make-ring :delete-function delete-function

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp

    r7844 r7993  
    240240                          (round (- time (tq-event-last-time event))
    241241                                 internal-time-units-per-second)))
    242                (hemlock-ext:without-interrupts
     242               (without-interrupts
    243243                (let ((interval (tq-event-interval event)))
    244244                  (when interval

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp

    r7898 r7993  
    335335(defsetf last-command-type %set-last-command-type
    336336  "Set the Last-Command-Type for use by the next command.")
    337 (defsetf last-key-event-typed %set-last-key-event-typed
    338   "Set the last key event typed")
    339337(defsetf logical-key-event-p %set-logical-key-event-p
    340338  "Change what Logical-Char= returns for the specified arguments.")

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

    r7933 r7993  
    4040   (quote-next-p :initform nil :accessor hemlock-view-quote-next-p)
    4141   (current-command :initform (make-array 10 :fill-pointer 0 :adjustable t)
    42                     :reader hemlock-current-command)
    43    (current-translation :initform (make-array 10 :fill-pointer 0 :adjustable t)
    44                         :reader hemlock-current-translation)
    45    (translate-key-temp :initform (make-array 10 :fill-pointer 0 :adjustable t)
    46                        :reader hemlock-translate-key-temp)
     42                    :accessor hemlock-current-command)
     43   (last-command :initform (make-array 10 :fill-pointer 0 :adjustable t)
     44                 :accessor hemlock-last-command)
    4745   (prefix-argument-state :initform (make-prefix-argument-state)
    4846                          :accessor hemlock-prefix-argument-state)
    … …  
    5351
    5452   ;; User level "view variables", for now give each its own slot.
    55    (last-key-event-typed :initform nil :accessor hemlock-last-key-event-typed)
    5653   (last-command-type :initform nil :accessor hemlock-last-command-type)
    5754   (target-column :initform 0 :accessor hemlock-target-column)
    … …  
    6966(defun last-key-event-typed ()
    7067  "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))
     68  (let* ((view (current-view))
     69         (keys (hemlock-current-command view)))
     70    (when (= (length keys) 0) ;; the normal case, when executing a command.
     71      (setq keys (hemlock-last-command view)))
     72    (when (> (length keys) 0)
     73      (aref keys (1- (length keys))))))
    7574
    7675(defun last-char-typed ()
    77   (let ((key (hemlock-last-key-event-typed (current-view))))
    78     (when key (hemlock-ext:key-event-char key))))
    79 
     76  (let ((key (last-key-event-typed)))
     77    (and key (key-event-char key))))
    8078
    8179;; This handles errors in event handling.  It assumes it's called in a normal
    … …  
    135133      (abort))))
    136134
    137 (defmethod translate-and-lookup-current-command ((view hemlock-view))
     135;; These are only used in event handling, and as such are serialized
     136(defparameter *translation-temp-1* (make-array 10 :fill-pointer 0 :adjustable t))
     137(defparameter *translation-temp-2* (make-array 10 :fill-pointer 0 :adjustable t))
     138
     139(defmethod translate-and-lookup-command (keys)
    138140  ;; Returns NIL if we're in the middle of a command (either multi-key, as in c-x,
    139141  ;; or translation prefix, as in ESC for Meta-), else a command.
    140142  (multiple-value-bind (translated-key prefix-p)
    141                        (translate-key (hemlock-current-command view)
    142                                       (hemlock-current-translation view)
    143                                       (hemlock-translate-key-temp view))
     143                       (translate-key keys *translation-temp-1* *translation-temp-2*)
    144144    (multiple-value-bind (res t-bindings)
    145145                         (get-current-binding translated-key)
    … …  
    153153           nil
    154154           (values (get-default-command) nil)))))))
    155  
     155
    156156
    157157;; This has a side effect of resetting the quoting state and current command.
    158158(defmethod get-command-binding-for-key ((view hemlock-view) key)
    159   (vector-push-extend key (hemlock-current-command view))
    160   (setf (hemlock-last-key-event-typed view) key)
    161   (multiple-value-bind (main-binding t-bindings)
    162                        (if (shiftf (hemlock-view-quote-next-p view) nil)
    163                          (values (get-self-insert-command) nil)
    164                          (let ((eps (hemlock-prompted-input-state view)))
    165                            (or (and eps (eps-parse-key-handler eps))
    166                                (translate-and-lookup-current-command view))))
    167     (when main-binding
    168       (setf (fill-pointer (hemlock-current-command view)) 0))
    169     (values main-binding t-bindings)))
     159  (let ((current-keys (hemlock-current-command view)))
     160    (vector-push-extend key current-keys)
     161    (multiple-value-bind (main-binding t-bindings)
     162                         (if (shiftf (hemlock-view-quote-next-p view) nil)
     163                           (values (get-self-insert-command) nil)
     164                           (let ((eps (hemlock-prompted-input-state view)))
     165                             (or (and eps (eps-parse-key-handler eps))
     166                                 (translate-and-lookup-command current-keys))))
     167      (when main-binding
     168        (let ((vec (hemlock-last-command view))) ;; reuse vector
     169          (setf (hemlock-last-command view) current-keys)
     170          (setf (fill-pointer vec) 0)
     171          (setf (hemlock-current-command view) vec))
     172        (values main-binding t-bindings)))))
    170173
    171174(defvar *last-last-command-type*)
    172175(defvar *last-prefix-argument*)
    173176
    174 ;;;
    175 (defvar *invoke-hook* #'(lambda (command p) (funcall (command-function command) p))
    176   "This function is called by the command interpreter when it wants to invoke a
    177   command.  The arguments are the command to invoke and the prefix argument.
    178   The default value just calls the Command-Function with the prefix argument.")
    179 
     177(defun invoke-command (command p)
     178  (funcall (command-function command) p))
    180179
    181180(defmethod execute-hemlock-key ((view hemlock-view) key)
    182181  #+gz (log-debug "~&execute-hemlock-key ~s" key)
    183   (if (or (symbolp key) (functionp key))
    184     (funcall key)
    185     (with-output-to-listener
    186       (multiple-value-bind (main-binding transparent-bindings)
    187                            (get-command-binding-for-key view key)
    188         #+gz (log-debug "~&  binding ~s ~s" main-binding transparent-bindings)
    189         (when main-binding
    190           (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
    191                  (*last-prefix-argument* (hemlock::prefix-argument-resetting-state))
    192                  ;(*echo-area-stream* (hemlock-echo-area-stream view))
    193                  )
    194             (dolist (binding transparent-bindings)
    195               (funcall *invoke-hook* binding *last-prefix-argument*))
    196             (funcall *invoke-hook* main-binding *last-prefix-argument*)))))))
     182  (with-output-to-listener
     183   (if (or (symbolp key) (functionp key))
     184     (funcall key)
     185     (multiple-value-bind (main-binding transparent-bindings)
     186                          (get-command-binding-for-key view key)
     187       #+gz (log-debug "~&  binding ~s ~s" main-binding transparent-bindings)
     188       (when main-binding
     189         (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
     190                (*last-prefix-argument* (hemlock::prefix-argument-resetting-state)))
     191           (dolist (binding transparent-bindings)
     192             (invoke-command binding *last-prefix-argument*))
     193           (invoke-command main-binding *last-prefix-argument*)))))))
    197194
    198195(defmethod update-echo-area-after-command ((view hemlock-view))
    … …  
    208205            (let ((cmd (hemlock-current-command view)))
    209206              (unless (eql 0 (length cmd))
    210                 (let ((cstr (with-output-to-string (s)
    211                               (loop for key across cmd
    212                                 do (hemlock-ext:print-pretty-key key s)
    213                                 do (write-char #\space s)))))
     207                (let ((cstr (concatenate 'string (pretty-key-string cmd) " ")))
    214208                  (message cstr))))))))))
    215209
Note: See TracChangeset for help on using the changeset viewer.