Index: /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7993) @@ -157,10 +157,76 @@ buf)) -;;; Define some key event modifiers. - -(hemlock-ext:define-modifier-bit #$NSShiftKeyMask "Shift") -(hemlock-ext:define-modifier-bit #$NSControlKeyMask "Control") -(hemlock-ext:define-modifier-bit #$NSAlternateKeyMask "Meta") -(hemlock-ext:define-modifier-bit #$NSAlphaShiftKeyMask "Lock") +;;; Define some key event modifiers and keysym codes + +(hi:define-modifier-bit #$NSShiftKeyMask "Shift") +(hi:define-modifier-bit #$NSControlKeyMask "Control") +(hi:define-modifier-bit #$NSAlternateKeyMask "Meta") +(hi:define-modifier-bit #$NSAlphaShiftKeyMask "Lock") + +(hi:define-keysym-code :F1 #$NSF1FunctionKey) +(hi:define-keysym-code :F2 #$NSF2FunctionKey) +(hi:define-keysym-code :F3 #$NSF3FunctionKey) +(hi:define-keysym-code :F4 #$NSF4FunctionKey) +(hi:define-keysym-code :F5 #$NSF5FunctionKey) +(hi:define-keysym-code :F6 #$NSF6FunctionKey) +(hi:define-keysym-code :F7 #$NSF7FunctionKey) +(hi:define-keysym-code :F8 #$NSF8FunctionKey) +(hi:define-keysym-code :F9 #$NSF9FunctionKey) +(hi:define-keysym-code :F10 #$NSF10FunctionKey) +(hi:define-keysym-code :F11 #$NSF11FunctionKey) +(hi:define-keysym-code :F12 #$NSF12FunctionKey) +(hi:define-keysym-code :F13 #$NSF13FunctionKey) +(hi:define-keysym-code :F14 #$NSF14FunctionKey) +(hi:define-keysym-code :F15 #$NSF15FunctionKey) +(hi:define-keysym-code :F16 #$NSF16FunctionKey) +(hi:define-keysym-code :F17 #$NSF17FunctionKey) +(hi:define-keysym-code :F18 #$NSF18FunctionKey) +(hi:define-keysym-code :F19 #$NSF19FunctionKey) +(hi:define-keysym-code :F20 #$NSF20FunctionKey) +(hi:define-keysym-code :F21 #$NSF21FunctionKey) +(hi:define-keysym-code :F22 #$NSF22FunctionKey) +(hi:define-keysym-code :F23 #$NSF23FunctionKey) +(hi:define-keysym-code :F24 #$NSF24FunctionKey) +(hi:define-keysym-code :F25 #$NSF25FunctionKey) +(hi:define-keysym-code :F26 #$NSF26FunctionKey) +(hi:define-keysym-code :F27 #$NSF27FunctionKey) +(hi:define-keysym-code :F28 #$NSF28FunctionKey) +(hi:define-keysym-code :F29 #$NSF29FunctionKey) +(hi:define-keysym-code :F30 #$NSF30FunctionKey) +(hi:define-keysym-code :F31 #$NSF31FunctionKey) +(hi:define-keysym-code :F32 #$NSF32FunctionKey) +(hi:define-keysym-code :F33 #$NSF33FunctionKey) +(hi:define-keysym-code :F34 #$NSF34FunctionKey) +(hi:define-keysym-code :F35 #$NSF35FunctionKey) + +;;; Upper right key bank. +;;; +(hi:define-keysym-code :Printscreen #$NSPrintScreenFunctionKey) +;; Couldn't type scroll lock. +(hi:define-keysym-code :Pause #$NSPauseFunctionKey) + +;;; Middle right key bank. +;;; +(hi:define-keysym-code :Insert #$NSInsertFunctionKey) +(hi:define-keysym-code :Del #$NSDeleteFunctionKey) +(hi:define-keysym-code :Home #$NSHomeFunctionKey) +(hi:define-keysym-code :Pageup #$NSPageUpFunctionKey) +(hi:define-keysym-code :End #$NSEndFunctionKey) +(hi:define-keysym-code :Pagedown #$NSPageDownFunctionKey) + +;;; Arrows. +;;; +(hi:define-keysym-code :Leftarrow #$NSLeftArrowFunctionKey) +(hi:define-keysym-code :Uparrow #$NSUpArrowFunctionKey) +(hi:define-keysym-code :Downarrow #$NSDownArrowFunctionKey) +(hi:define-keysym-code :Rightarrow #$NSRightArrowFunctionKey) + +;;; + +;(hi:define-keysym-code :linefeed 65290) + + + + @@ -467,5 +533,5 @@ (defmethod assume-not-editing ((ts hemlock-text-storage)) - #+debug (assert (eql (slot-value ts 'edit-count) 0))) + #+debug NIL (assert (eql (slot-value ts 'edit-count) 0))) (defun textstorage-note-insertion-at-position (self pos n) @@ -851,5 +917,5 @@ (call-next-method))) -(defconstant +shift-event-mask+ (hemlock-ext:key-event-modifier-mask "Shift")) +(defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift")) ;;; Translate a keyDown NSEvent to a Hemlock key-event. @@ -872,12 +938,12 @@ #$NSAlphaShiftKeyMask)))) (unless quote-p - (dolist (map hemlock-ext::*modifier-translations*) + (dolist (map hi:*modifier-translations*) (when (logtest useful-modifiers (car map)) (setq bits (logior bits - (hemlock-ext:key-event-modifier-mask (cdr map))))))) + (hi:key-event-modifier-mask (cdr map))))))) (let* ((char (code-char c))) (when (and char (standard-char-p char)) (setq bits (logandc2 bits +shift-event-mask+)))) - (hemlock-ext:make-key-event c bits))))))) + (hi:make-key-event c bits))))))) ;; For now, this is only used to abort i-search. All actual mouse handling is done @@ -1395,4 +1461,12 @@ (mapcar #'(lambda (field) + #+GZ (or (ignore-errors (funcall (hi::modeline-field-function field) + buffer pane)) + (format nil "#<~s ~s>" (hi::modeline-field-name field) + (and (eq (hi::modeline-field-name field) :package) + (hi::variable-value 'hemlock::current-package + :buffer buffer)))) + + #-GZ (funcall (hi::modeline-field-function field) buffer pane)) @@ -1621,5 +1695,5 @@ (defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane) - #+GZ (log-debug "change active pane, current: ~s" new-pane) + #+GZ (log-debug "change active pane to ~s" new-pane) (let* ((pane (hi::hemlock-view-pane view)) (text-view (text-pane-text-view pane)) @@ -1899,7 +1973,4 @@ (setf (slot-value frame 'echo-area-view) echo-area (slot-value frame 'pane) pane) - #+GZ (log-debug "~&echo-area: ~s textstorage: ~s" - echo-area - (#/textStorage echo-area)) (setf (slot-value pane 'hemlock-view) (make-instance 'hi:hemlock-view @@ -1907,5 +1978,4 @@ :pane pane :echo-area-buffer echo-buffer)) - (activate-hemlock-view tv) frame)) Index: /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp (revision 7993) @@ -31,21 +31,107 @@ -;;; Setup the server end of a pty pair. -(defun setup-server-pty (pty) - (set-tty-raw pty) - pty) - -;;; Setup the client end of a pty pair. -(defun setup-client-pty (pty) - ;; Since the same (Unix) process will be reading from and writing - ;; to the pty, it's critical that we make the pty non-blocking. - ;; Has this been true for the last few years (native threads) ? - ;(fd-set-flag pty #$O_NONBLOCK) - (set-tty-raw pty) - #+no - (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG)) - #+no - (disable-tty-output-modes pty #$ONLCR) - pty) +(defclass cocoa-listener-input-stream (fundamental-character-input-stream) + ((queue :initform ()) + (queue-lock :initform (make-lock)) + (read-lock :initform (make-lock)) + (queue-semaphore :initform (make-semaphore)) ;; total queue count + (text-semaphore :initform (make-semaphore)) ;; text-only queue count + (cur-string :initform nil) + (cur-string-pos :initform 0) + (cur-env :initform nil) + (cur-sstream :initform nil))) + +(defmethod dequeue-listener-char ((stream cocoa-listener-input-stream) wait-p) + (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream + (with-lock-grabbed (read-lock) + (or (with-lock-grabbed (queue-lock) + (when (< cur-string-pos (length cur-string)) + (prog1 (aref cur-string cur-string-pos) (incf cur-string-pos)))) + (loop + (unless (if wait-p + (wait-on-semaphore text-semaphore nil "Listener Input") + (timed-wait-on-semaphore text-semaphore 0)) + (return nil)) + (assert (timed-wait-on-semaphore queue-semaphore 0) () "queue/text mismatch!") + (with-lock-grabbed (queue-lock) + (let* ((s (find-if #'stringp queue))) + (assert s () "queue/semaphore mismatch!") + (setq queue (delq s queue 1)) + (when (< 0 (length s)) + (setf cur-string s cur-string-pos 1) + (return (aref s 0)))))))))) + +(defmethod ccl::read-toplevel-form ((stream cocoa-listener-input-stream) eof-value) + (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos cur-sstream cur-env) stream + (with-lock-grabbed (read-lock) + (loop + (when cur-sstream + (let* ((env cur-env) + (form (progv (car env) (cdr env) + (ccl::read-toplevel-form cur-sstream eof-value))) + (last-form-in-selection (not (listen cur-sstream)))) + (when last-form-in-selection + (setf cur-sstream nil cur-env nil)) + (return (values form env (or last-form-in-selection ccl::*verbose-eval-selection*))))) + (when (with-lock-grabbed (queue-lock) + (loop + unless (< cur-string-pos (length cur-string)) return nil + unless (whitespacep (aref cur-string cur-string-pos)) return t + do (incf cur-string-pos))) + (return (values (call-next-method) nil t))) + (wait-on-semaphore queue-semaphore nil "Toplevel Read") + (let ((val (with-lock-grabbed (queue-lock) (pop queue)))) + (cond ((stringp val) + (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!") + (setq cur-string val cur-string-pos 0)) + (t + (destructuring-bind (string package-name pathname) val + (let ((env (cons '(*loading-file-source-file*) (list pathname)))) + (when package-name + (push '*package* (car env)) + (push (ccl::pkg-arg package-name) (cdr env))) + (setf cur-sstream (make-string-input-stream string) cur-env env)))))))))) + +(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname) + (with-slots (queue-lock queue queue-semaphore) stream + (with-lock-grabbed (queue-lock) + (setq queue (nconc queue (list (list string package-name pathname)))) + (signal-semaphore queue-semaphore)))) + +(defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string) + (with-slots (queue-lock queue queue-semaphore text-semaphore) stream + (with-lock-grabbed (queue-lock) + (setq queue (nconc queue (list string))) + (signal-semaphore queue-semaphore) + (signal-semaphore text-semaphore)))) + +(defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream)) + (dequeue-listener-char stream nil)) + +(defmethod stream-read-char ((stream cocoa-listener-input-stream)) + (dequeue-listener-char stream t)) + +(defmethod stream-unread-char ((stream cocoa-listener-input-stream) char) + ;; Can't guarantee the right order of reads/unreads, just make sure not to + ;; introduce any internal inconsistencies (and dtrt for the non-conflict case). + (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream + (with-lock-grabbed (queue-lock) + (cond ((>= cur-string-pos (length cur-string)) + (push (string char) queue) + (signal-semaphore queue-semaphore) + (signal-semaphore text-semaphore)) + ((< 0 cur-string-pos) + (decf cur-string-pos) + (setf (aref cur-string cur-string-pos) char)) + (t (setf cur-string (concatenate 'string (string char) cur-string))))))) + +(defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream)) + t) + +(defmethod stream-clear-input ((stream cocoa-listener-input-stream)) + (with-slots (queue-lock cur-string cur-string-pos) stream + (with-lock-grabbed (queue-lock) + (setf cur-string nil cur-string-pos 0)))) + (defparameter $listener-flush-limit 100) @@ -124,5 +210,4 @@ ((input-stream :reader cocoa-listener-process-input-stream) (output-stream :reader cocoa-listener-process-output-stream) - (input-peer-stream :reader cocoa-listener-process-input-peer-stream) (backtrace-contexts :initform nil :accessor cocoa-listener-process-backtrace-contexts) @@ -130,22 +215,9 @@ -(defun new-cocoa-listener-process (procname input-fd peer-fd window) - (let* ((input-stream (ccl::make-selection-input-stream - input-fd - :peer-fd peer-fd - :elements-per-buffer (#_fpathconf - input-fd - #$_PC_MAX_INPUT) - :encoding :utf-8)) - (peer-stream (ccl::make-fd-stream peer-fd :direction :output - :sharing :lock - :elements-per-buffer - (#_fpathconf - peer-fd - #$_PC_MAX_INPUT) - :encoding :utf-8)) +(defun new-cocoa-listener-process (procname window) + (let* ((input-stream (make-instance 'cocoa-listener-input-stream)) (output-stream (make-instance 'cocoa-listener-output-stream :hemlock-view (hemlock-view window))) - + (proc (ccl::make-mcl-listener-process @@ -174,9 +246,7 @@ (setf (slot-value proc 'input-stream) input-stream) (setf (slot-value proc 'output-stream) output-stream) - (setf (slot-value proc 'input-peer-stream) peer-stream) (setf (slot-value proc 'window) window) proc)) - - + (defclass hemlock-listener-frame (hemlock-frame) () @@ -186,7 +256,5 @@ (defclass hemlock-listener-window-controller (hemlock-editor-window-controller) - ((filehandle :foreign-type :id) ;Filehandle for I/O - (clientfd :foreign-type :int) ;Client (listener)'s side of pty - ) + () (:metaclass ns:+ns-object) ) @@ -199,17 +267,4 @@ (declare (ignorable edited))) - -(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w) - (let* ((new (call-next-method w))) - (unless (%null-ptr-p new) - (multiple-value-bind (server client) (ignore-errors (open-pty-pair)) - (when server - (let* ((fh (make-instance - 'ns:ns-file-handle - :with-file-descriptor (setup-server-pty server) - :close-on-dealloc t))) - (setf (slot-value new 'filehandle) fh) - (setf (slot-value new 'clientfd) (setup-client-pty client)))))) - new)) (objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name) @@ -252,9 +307,4 @@ (defmethod textview-background-color ((doc hemlock-listener-document)) *listener-background-color*) - -(defun hemlock-ext:send-string-to-listener (buffer string) - (let* ((proc (buffer-process buffer))) - (when proc - (send-string-to-listener-process proc string)))) ;; For use with the :process-info listener modeline field @@ -370,7 +420,5 @@ *next-listener-y-pos* (ns:ns-point-y new-point)))) (setf (hemlock-document-process self) - (let* ((tty (slot-value controller 'clientfd)) - (peer-tty (#/fileDescriptor (slot-value controller 'filehandle)))) - (new-cocoa-listener-process listener-name tty peer-tty window))) + (new-cocoa-listener-process listener-name window)) controller)) @@ -521,32 +569,19 @@ (setf (hi::variable-value 'hemlock::current-package :buffer buf) name))))))) + +(defmethod eval-in-listener-process ((process cocoa-listener-process) + string &key path package) + (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string + :package-name package :pathname path)) + ;;; This is basically used to provide INPUT to the listener process, by -;;; writing to an fd which is conntected to that process's standard +;;; writing to an fd which is connected to that process's standard ;;; input. -(defmethod send-string-to-listener-process ((process cocoa-listener-process) - string &key path package) - (let* ((stream (cocoa-listener-process-input-peer-stream process))) - (labels ((out-raw-char (ch) - (write-char ch stream)) - (out-ch (ch) - (when (or (eql ch #\^v) - (eql ch #\^p) - (eql ch #\newline) - (eql ch #\^q) - (eql ch #\^d)) - (out-raw-char #\^q)) - (out-raw-char ch)) - (out-string (s) - (dotimes (i (length s)) - (out-ch (char s i))))) - (out-raw-char #\^p) - (when package (out-string package)) - (out-raw-char #\newline) - (out-raw-char #\^v) - (when path (out-string path)) - (out-raw-char #\newline) - (out-string string) - (out-raw-char #\^d) - (force-output stream)))) +(defun hemlock-ext:send-string-to-listener (listener-buffer string) + (let* ((process (buffer-process listener-buffer))) + (unless process + (error "No listener process found for ~s" listener-buffer)) + (enqueue-listener-input (cocoa-listener-process-input-stream process) string))) + @@ -570,5 +605,5 @@ (when target-listener (destructuring-bind (package path string) selection - (send-string-to-listener-process target-listener string :package package :path path))))) + (eval-in-listener-process target-listener string :package package :path path))))) (defmethod ui-object-load-buffer ((app ns:ns-application) selection) @@ -577,5 +612,5 @@ (destructuring-bind (package path) selection (let ((string (format nil "(load ~S)" path))) - (send-string-to-listener-process target-listener string :package package :path path)))))) + (eval-in-listener-process target-listener string :package package :path path)))))) (defmethod ui-object-compile-buffer ((app ns:ns-application) selection) @@ -584,5 +619,5 @@ (destructuring-bind (package path) selection (let ((string (format nil "(compile-file ~S)" path))) - (send-string-to-listener-process target-listener string :package package :path path)))))) + (eval-in-listener-process target-listener string :package package :path path)))))) (defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection) @@ -595,5 +630,5 @@ :name (pathname-name path) :type (pathname-type path))))) - (send-string-to-listener-process target-listener string :package package :path path)))))) + (eval-in-listener-process target-listener string :package package :path path)))))) Index: /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp (revision 7993) @@ -32,7 +32,4 @@ '("package" - ;; Lisp implementation specific stuff goes into one of - ;; the next two files. - "lispdep" "hemlock-ext" Index: /branches/event-ide/ccl/cocoa-ide/defsystem.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/defsystem.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/defsystem.lisp (revision 7993) @@ -16,7 +16,4 @@ (require "OBJC-SUPPORT") - -(require "PTY") - (defpackage "GUI" @@ -55,7 +52,4 @@ objc-message-send open-main-bundle - ;; Symbols perhaps that should be exported by library;pty.lisp but aren't - open-pty-pair - set-tty-raw ) (:export Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp (revision 7993) @@ -37,6 +37,6 @@ ;;; Self insert letters: ;;; -(hemlock-ext:do-alpha-key-events (key-event :both) - (bind-key "Self Insert" key-event)) +(do-alpha-key-events (key-event :both) + (bind-key "Self Insert" key-event)) (bind-key "Beginning of Line" #k"control-a") @@ -568,5 +568,5 @@ (do ((i 33 (1+ i))) ((= i 126)) - (let ((key-event (hemlock-ext:char-key-event (code-char i)))) + (let ((key-event (hi:char-key-event (code-char i)))) (bind-key "Self Overwrite" key-event :mode "Overwrite"))) @@ -631,7 +631,7 @@ ;;; message about modifying read-only buffers. ;;; -(hemlock-ext:do-alpha-key-events (key-event :both) - (bind-key "Illegal" key-event :mode "Headers") - (bind-key "Illegal" key-event :mode "Message")) +(do-alpha-key-events (key-event :both) + (bind-key "Illegal" key-event :mode "Headers") + (bind-key "Illegal" key-event :mode "Message")) ;;; Global. @@ -725,7 +725,7 @@ ;;; message about modifying read-only buffers. ;;; -(hemlock-ext:do-alpha-key-events (key-event :both) - (bind-key "Illegal" key-event :mode "News-Headers") - (bind-key "Illegal" key-event :mode "News-Message")) +(do-alpha-key-events (key-event :both) + (bind-key "Illegal" key-event :mode "News-Headers") + (bind-key "Illegal" key-event :mode "News-Message")) @@ -934,6 +934,6 @@ ;;;; Caps-Lock mode. -(hemlock-ext:do-alpha-key-events (key-event :lower) - (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK")) +(do-alpha-key-events (key-event :lower) + (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK")) @@ -943,7 +943,7 @@ ;;;; Anything that's not explicitly bound here will exit i-search. -(dotimes (n hemlock::char-code-limit) +(dotimes (n hi::hemlock-char-code-limit) (when (standard-char-p (code-char n)) - (let ((key (hemlock-ext:make-key-event n))) + (let ((key (make-key-event n))) (bind-key "I-Search Self Insert" key :mode "I-Search")))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp (revision 7993) @@ -150,5 +150,5 @@ ;;; (defun unwind-bindings (buffer mode) - #+gz (assert (buffer-bindings-wound-p buffer)) + (assert (buffer-bindings-wound-p buffer)) (setf (buffer-bindings-wound-p buffer) nil) (unbind-variable-bindings (buffer-var-values buffer)) @@ -167,5 +167,5 @@ ;;; (defun wind-bindings (buffer modes) - #+gz (assert (not (buffer-bindings-wound-p buffer))) + (assert (not (buffer-bindings-wound-p buffer))) (setf (buffer-bindings-wound-p buffer) t) (do ((curmode (buffer-mode-objects buffer)) cw) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/charmacs.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/charmacs.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/charmacs.lisp (revision 7993) @@ -31,5 +31,5 @@ ;;;; Stuff for the Syntax table functions (syntax) -(defconstant syntax-char-code-limit char-code-limit +(defconstant syntax-char-code-limit hemlock-char-code-limit "The highest char-code which a character argument to the syntax table functions may have.") Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7993) @@ -250,17 +250,17 @@ "Moves the down p lines, collapsing the selection." (let* ((point (current-point-collapsing-selection)) - (target (set-target-column point))) - (unless (line-offset point (or p 1)) - (when (value next-line-inserts-newlines) - (cond ((not p) - (when (same-line-p point (buffer-end-mark (current-buffer))) - (line-end point)) - (insert-character point #\newline)) - ((minusp p) - (buffer-start point) - (editor-error "No previous line.")) - (t - (buffer-end point) - (when p (editor-error "No next line.")))))) + (target (set-target-column point)) + (count (or p 1))) + (unless (line-offset point count) + (cond ((and (not p) (value next-line-inserts-newlines)) + (when (same-line-p point (buffer-end-mark (current-buffer))) + (line-end point)) + (insert-character point #\newline)) + ((minusp count) + (buffer-start point) + (editor-error "No previous line.")) + (t + (buffer-end point) + (editor-error "No next line.")))) (unless (move-to-position point target) (line-end point)) (setf (last-command-type) :line-motion))) @@ -482,6 +482,6 @@ (let* ((ps (current-prefix-argument-state)) (key-event (last-key-event-typed)) - (stripped-key-event (hemlock-ext:make-key-event key-event)) - (char (hemlock-ext:key-event-char stripped-key-event)) + (stripped-key-event (make-key-event key-event)) + (char (key-event-char stripped-key-event)) (digit (if char (digit-char-p char)))) (when (null (ps-result ps)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp (revision 7993) @@ -176,8 +176,9 @@ which is prompted for." (declare (ignore p)) - (multiple-value-bind (key res) (prompt-for-command-key) + (multiple-value-bind (key res) (prompt-for-key :prompt "Describe key: " + :must-exist t) (cond ((commandp res) (with-pop-up-display (s :title "Key documentation") - (hemlock-ext:print-pretty-key key s) + (write-string (pretty-key-string key) s) (format s " is bound to ~S.~%" (command-name res)) (format s "Documentation for this command:~% ~A" @@ -185,5 +186,5 @@ (t (with-pop-up-display (s :height 1) - (hemlock-ext:print-pretty-key key s) + (write-string (pretty-key-string key) s) (write-string " is not bound to anything." s)))))) @@ -308,5 +309,5 @@ *describe-mode-ignore* :test #'string-equal) - (let ((str (key-to-string key))) + (let ((str (pretty-key-string key))) (cond ((= (length str) 1) (write-string str s) @@ -317,11 +318,4 @@ :mode name)))) -(defun key-to-string (key) - (with-output-to-string (s) - (hemlock-ext:print-pretty-key key s))) - - - - ;;;; Printing bindings and last N characters typed. @@ -335,5 +329,5 @@ (do ((i (1- num) (1- i))) ((minusp i)) - (hemlock-ext:print-pretty-key-event (ring-ref *key-event-history* i) s) + (write-string (pretty-key-string (ring-ref *key-event-history* i)) s) (write-char #\space s))))) @@ -373,5 +367,5 @@ (do ((key keys (cdr key))) ((null (cdr key)) - (hemlock-ext:print-pretty-key (car key) stream)) - (hemlock-ext:print-pretty-key (car key) stream) + (write-string (pretty-key-string (car key)) stream)) + (write-string (pretty-key-string (car key)) stream) (write-string ", " stream))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 7993) @@ -42,15 +42,15 @@ ;; TODO: used to do something cleverish if in the middle of reading prompted input, might ;; want to address that. - (if *current-view* - (let ((message (apply #'format nil string args))) - (modifying-echo-buffer - (delete-region (buffer-region *current-buffer*)) - (insert-string (buffer-point *current-buffer*) message) - (setq *last-message-time* (get-internal-real-time)) - )) - ;; For some reason this crashes. Perhaps something is too aggressive about - ;; catching conditions in events?? - #+not-yet(apply #'warn string args) - #-not-yet (apply #'format t string args))) + (if *current-view* + (let ((message (apply #'format nil string args))) + (modifying-echo-buffer + (delete-region (buffer-region *current-buffer*)) + (insert-string (buffer-point *current-buffer*) message) + (setq *last-message-time* (get-internal-real-time)) + )) + ;; For some reason this crashes. Perhaps something is too aggressive about + ;; catching conditions in events?? + #+not-yet(apply #'warn string args) + #-not-yet (apply #'format t string args))) ;;; LOUD-MESSAGE -- Public. @@ -163,18 +163,18 @@ (when old-eps (editor-error "Attempt to recursively use echo area")) - (unwind-protect - (let ((*recursive-edit-view* view)) - (setf (hemlock-prompted-input-state view) eps) - (unless old-eps - (hemlock-ext:change-active-pane view :echo)) - (display-prompt-nicely eps) - (modifying-buffer-storage (nil) - (with-standard-standard-output - (gui::event-loop #'(lambda () (eps-parse-results eps))))) - #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps))) - (setf (hemlock-prompted-input-state view) old-eps) - (unless old-eps - (hemlock-ext:change-active-pane view :text)) - (delete-mark parse-mark)) + (display-prompt-nicely eps) + (modifying-buffer-storage (nil) + (unwind-protect + (let ((*recursive-edit-view* view)) + (setf (hemlock-prompted-input-state view) eps) + (unless old-eps + (hemlock-ext:change-active-pane view :echo)) + (with-standard-standard-output + (gui::event-loop #'(lambda () (eps-parse-results eps)))) + #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps))) + (unless old-eps + (hemlock-ext:change-active-pane view :text)) + (setf (hemlock-prompted-input-state view) old-eps) + (delete-mark parse-mark))) (let ((results (eps-parse-results eps))) (if (listp results) @@ -519,10 +519,10 @@ (values (list (equalp (eps-parse-default eps) "y")) t)) ((logical-key-event-p key-event :abort) - (values nil nil)) ;; default action + :abort) ((logical-key-event-p key-event :help) - (values nil nil)) ;; default action + :help) (t (if (eps-parse-value-must-exist eps) - (values nil nil) ;; default action + :error (values (list key-event) t))))) :type :key @@ -551,66 +551,60 @@ :key-handler (getstring "Key Input Handler" *command-names*))) -#+not-yet -(defun prompt-for-key (&key (must-exist t) - default default-string - (prompt "Key: ") - (help "Type a key.")) - (let ((string (if default - (or default-string - (let ((l (coerce default 'list))) - (format nil "~:C~{ ~:C~}" (car l) (cdr l))))))) - (with-echo-area-window - (display-prompt-nicely prompt string) - (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event) - (declare (vector key)) - TOP - (setf key-event (recursive-get-key-event *editor-input*)) - (cond ((logical-key-event-p key-event :quote) - (setf key-event (recursive-get-key-event *editor-input* t))) - ((logical-key-event-p key-event :confirm) - (cond ((and default (zerop (length key))) - (let ((res (get-command default :current))) - (unless (commandp res) (go FLAME)) - (return (values default res)))) - ((and (not must-exist) (plusp (length key))) - (return (copy-seq key))) - (t - (go FLAME)))) - ((logical-key-event-p key-event :help) - (hemlock::help-on-parse-command ()) - (go TOP))) - (vector-push-extend key-event key) - (when must-exist - (let ((res (get-command key :current))) - (cond ((commandp res) - (hemlock-ext:print-pretty-key-event key-event - *echo-area-stream* - t) - (write-char #\space *echo-area-stream*) - (return (values (copy-seq key) res))) - ((not (eq res :prefix)) - (vector-pop key) - (go FLAME))))) - (hemlock-ext:print-pretty-key key-event *echo-area-stream* t) - (write-char #\space *echo-area-stream*) - (go TOP) - FLAME - (beep) - (go TOP)) - (force-output *echo-area-stream*)))) - -#+not-yet -(defun prompt-for-command-key () - (with-echo-area-window - (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0))) - (hi::display-prompt-nicely "Describe key: " nil) - (loop - (let ((key-event (get-key-event hi::*editor-input*))) - (vector-push-extend key-event prompt-key) - (let ((res (get-command prompt-key :current))) - (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*) - (write-char #\space *echo-area-stream*) - (unless (eq res :prefix) - (return (values (copy-seq prompt-key) res))))))))) +(defun verify-key (eps key-event key quote-p) + ;; This is called with the echo buffer as the current buffer. We want to look + ;; up the commands in the main buffer. + (let* ((buffer (hemlock-view-buffer (current-view))) + (n (length key))) + (block nil + (unless quote-p + (cond ((logical-key-event-p key-event :help) + (return :help)) + ((logical-key-event-p key-event :abort) + (return :abort)) + ((and (not (eps-parse-value-must-exist eps)) + (logical-key-event-p key-event :confirm)) + (return + (cond ((eql n 0) + (let ((key (eps-parse-default eps)) + (cmd (and key (with-buffer-bindings (buffer) + (get-command key :current))))) + (if (commandp cmd) + (values (list key cmd) :confirmed) + :error))) + ((> n 0) + (values (list key nil) :confirmed)) + (t :error)))))) + (vector-push-extend key-event key) + (let ((cmd (if (eps-parse-value-must-exist eps) + (with-buffer-bindings (buffer) (get-command key :current)) + :prefix))) + (cond ((commandp cmd) + (values (list key cmd) t)) + ((eq cmd :prefix) + nil) + (t + (vector-pop key) + :error)))))) + +(defun prompt-for-key (&key (prompt "Key: ") + (help "Type a key.") + default default-string + (must-exist t)) + (parse-for-something + :verification-function (let ((key (make-array 10 :adjustable t :fill-pointer 0)) + (quote-p nil)) + #'(lambda (eps key-event) + (if (and (not quote-p) (logical-key-event-p key-event :quote)) + (progn + (setq quote-p t) + (values :ignore nil)) + (verify-key eps key-event key (shiftf quote-p nil))))) + :type :command + :prompt prompt + :help help + :value-must-exist must-exist + :default default + :default-string default-string + :key-handler (getstring "Key Input Handler" *command-names*))) @@ -756,5 +750,5 @@ (cdr key-events))) ((null key-events)) - (hemlock-ext:print-pretty-key (car key-events) s) + (write-string (pretty-key-string (car key-events)) s) (unless (null (cdr key-events)) (write-string ", " s)))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp (revision 7993) @@ -121,7 +121,7 @@ (multiple-value-bind (result win) - (hemlock-ext:complete-file typein - :defaults (directory-namestring (eps-parse-default eps)) - :ignore-types (value ignore-file-types)) + (complete-file typein + :defaults (directory-namestring (eps-parse-default eps)) + :ignore-types (value ignore-file-types)) (when result (replace-parse-input-string eps (namestring result))) @@ -344,4 +344,9 @@ ;; +(defun append-key-name (key-event) + (let ((point (current-point))) + (insert-string point (pretty-key-string key-event t)) + (insert-character point #\Space))) + (defcommand "Key Input Handler" (p) "Internal command to handle input during y-or-n or key-event prompting" @@ -349,11 +354,20 @@ (let* ((eps (current-echo-parse-state)) (key-event (last-key-event-typed))) - (multiple-value-bind (res flag) + (multiple-value-bind (res exit-p) (funcall (eps-parse-verification-function eps) eps key-event) - (if flag - (exit-echo-parse eps res) - (cond ((logical-key-event-p key-event :abort) - (abort-to-toplevel)) - ((logical-key-event-p key-event :help) - (hemlock::help-on-parse-command nil)) - (t (beep))))))) + #+GZ (log-debug "Key Input Hander: res: ~s exit-p ~s" res exit-p) + (cond (exit-p + (unless (eq exit-p :confirmed) + (append-key-name key-event)) + (exit-echo-parse eps res)) + ((eq res :abort) + (abort-to-toplevel)) + ((eq res :help) + (help-on-parse-command nil)) + ((eq res :error) + (beep)) + ((eq res :ignore) + nil) + (t + (append-key-name key-event)))))) + Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp (revision 7993) @@ -110,10 +110,11 @@ (name command) (if p - (multiple-value-bind (key cmd) - (prompt-for-key :prompt "Edit command bound to: ") - (declare (ignore key)) - (values (command-name cmd) cmd)) - (prompt-for-keyword :tables (list *command-names*) - :prompt "Command to edit: ")) + (multiple-value-bind (key cmd) + (prompt-for-key :prompt "Edit command bound to: " + :must-exist t) + (declare (ignore key)) + (values (command-name cmd) cmd)) + (prompt-for-keyword :tables (list *command-names*) + :prompt "Command to edit: ")) (go-to-definition (fun-defined-from-pathname (command-function command)) :function Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp (revision 7993) @@ -401,5 +401,5 @@ (let* ((pathname (pathname pathname)) (trial-pathname (or (probe-file pathname) - (merge-pathnames pathname (hemlock-ext:default-directory)))) + (merge-pathnames pathname (default-directory)))) (found (find trial-pathname (the list *buffer-list*) :key #'buffer-pathname :test #'equal))) @@ -515,5 +515,5 @@ (setf (buffer-modified buffer) nil) (let ((stored-pathname (or probed-pathname - (merge-pathnames pathname (hemlock-ext:default-directory))))) + (merge-pathnames pathname (default-directory))))) (setf (buffer-pathname buffer) stored-pathname) (setf (value pathname-defaults) stored-pathname) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp (revision 7993) @@ -129,5 +129,5 @@ (get-command #k"Linefeed" :current) (declare (ignore command)) ;command is this one, so don't invoke it - (dolist (c t-bindings) (funcall *invoke-hook* c p))) + (dolist (c t-bindings) (invoke-command c p))) (indent-new-line-command nil))) @@ -148,5 +148,5 @@ (get-command #k"Return" :current) (declare (ignore command)) ;command is this one, so don't invoke it - (dolist (c t-bindings) (funcall *invoke-hook* c p))) + (dolist (c t-bindings) (invoke-command c p))) (new-line-command nil))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp (revision 7993) @@ -1,23 +1,9 @@ -;;; -*- Mode: LISP; Package: HEMLOCK-EXT -*- +;;; -*- Mode: LISP; Package: Hemlock-Internals -*- -(in-package :hemlock-ext) +(in-package :hemlock-internals) -(defconstant hi::char-code-limit 256) -(defconstant char-code-limit 256) +(defconstant hemlock-char-code-limit 256) -(defmacro file-comment (&rest ignore) - (declare (ignore ignore)) - nil) - -(defun skip-whitespace (&optional (stream *standard-input*)) - (peek-char t stream)) - -(defvar hi::*command-line-switches* nil) - -(defun hi::get-terminal-name () - "vt100") - -(defun hi::get-termcap-env-var () - (getenv "TERMCAP")) +(defvar *command-line-switches* nil) (defun default-directory () @@ -27,8 +13,36 @@ (truename #p"")) +(defun file-writable (pathname) + "File-writable accepts a pathname and returns T if the current + process can write it, and NIL otherwise. Also if the file does + not exist return T." + #+(or CMU scl) + (ext:file-writable pathname) + #-(or cmu scl) + (handler-case (let ((io (open pathname + :direction :output + :if-exists :append + :if-does-not-exist nil))) + (if io + (close io :abort t) + ;; more complicate situation: + ;; we want test if we can create the file. + (let ((io (open pathname + :direction :output + :if-exists nil + :if-does-not-exist :create))) + (if io + (progn + (close io) + (delete-file io)) + t)))) + (file-error (err) + (declare (ignore err)) + nil)) ) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun hi::%sp-byte-blt (src start dest dstart end) +(defun %sp-byte-blt (src start dest dstart end) (declare (type (simple-base-string src dest))) (loop for s from start @@ -37,5 +51,5 @@ (setf (aref dest d) (aref src s)))) -(defun hi::%sp-find-character-with-attribute (string start end table mask) +(defun %sp-find-character-with-attribute (string start end table mask) ;;(declare (type (simple-array (mod 256) char-code-max) table)) (declare (simple-string string)) @@ -52,5 +66,5 @@ (return index)))) -(defun hi::%sp-reverse-find-character-with-attribute (string start end table +(defun %sp-reverse-find-character-with-attribute (string start end table mask) ;;(declare (type (simple-array (mod 256) char-code-max) table)) @@ -64,5 +78,5 @@ (return index)))) -(defun hi::%sp-find-character (string start end character) +(defun %sp-find-character (string start end character) "%SP-Find-Character String, Start, End, Character Searches String for the Character from Start to End. If the character is @@ -78,140 +92,72 @@ (return i)))) -#-clozure -(defun delq (item list) - (delete item list :test #'eq)) - -#-clozure -(defun memq (item list) - (member item list :test #'eq)) - -#-clozure -(defun assq (item alist) - (assoc item alist :test #'eq)) - ;;;; complete-file -#-CMU -(progn - (defun complete-file (pathname &key (defaults *default-pathname-defaults*) - ignore-types) - (let ((files (complete-file-directory pathname defaults))) - (cond ((null files) - (values nil nil)) - ((null (cdr files)) - (values (car files) - t)) - (t - (let ((good-files - (delete-if #'(lambda (pathname) - (and (simple-string-p - (pathname-type pathname)) - (member (pathname-type pathname) - ignore-types - :test #'string=))) - files))) - (cond ((null good-files)) - ((null (cdr good-files)) - (return-from complete-file - (values (car good-files) - t))) - (t - (setf files good-files))) - (let ((common (file-namestring (car files)))) - (dolist (file (cdr files)) - (let ((name (file-namestring file))) - (dotimes (i (min (length common) (length name)) +(defun complete-file (pathname &key (defaults *default-pathname-defaults*) + ignore-types) + (let ((files (complete-file-directory pathname defaults))) + (cond ((null files) + (values nil nil)) + ((null (cdr files)) + (values (car files) + t)) + (t + (let ((good-files + (delete-if #'(lambda (pathname) + (and (simple-string-p + (pathname-type pathname)) + (member (pathname-type pathname) + ignore-types + :test #'string=))) + files))) + (cond ((null good-files)) + ((null (cdr good-files)) + (return-from complete-file + (values (car good-files) + t))) + (t + (setf files good-files))) + (let ((common (file-namestring (car files)))) + (dolist (file (cdr files)) + (let ((name (file-namestring file))) + (dotimes (i (min (length common) (length name)) (when (< (length name) (length common)) (setf common name))) - (unless (char= (schar common i) (schar name i)) - (setf common (subseq common 0 i)) - (return))))) - (values (merge-pathnames common pathname) - nil))))))) + (unless (char= (schar common i) (schar name i)) + (setf common (subseq common 0 i)) + (return))))) + (values (merge-pathnames common pathname) + nil))))))) ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal. ;;; - (defun complete-file-directory (pathname defaults) - (let* ((pathname (merge-pathnames pathname (directory-namestring defaults))) - (type (pathname-type pathname))) - (setf pathname - (make-pathname :defaults (truename (make-pathname :defaults pathname :name nil :type nil)) - :name (pathname-name pathname) - :type type)) - (delete-if-not (lambda (candidate) - (search (namestring pathname) (namestring candidate))) - (append - #+CLISP - (directory - (make-pathname :defaults pathname - :name :wild - :type nil)) ;gosh! - #+CLISP - (directory - (make-pathname :defaults pathname - :directory (append (pathname-directory pathname) (list "*")) ;gosh gosh! - :name nil - :type nil)))))) +(defun complete-file-directory (pathname defaults) + (let* ((pathname (merge-pathnames pathname (directory-namestring defaults))) + (type (pathname-type pathname))) + (setf pathname + (make-pathname :defaults (truename (make-pathname :defaults pathname :name nil :type nil)) + :name (pathname-name pathname) + :type type)) + (delete-if-not (lambda (candidate) + (search (namestring pathname) (namestring candidate))) + (append + #+CLISP + (directory + (make-pathname :defaults pathname + :name :wild + :type nil)) ;gosh! + #+CLISP + (directory + (make-pathname :defaults pathname + :directory (append (pathname-directory pathname) (list "*")) ;gosh gosh! + :name nil + :type nil)))))) ;;; Ambiguous-Files -- Public ;;; - (defun ambiguous-files (pathname - &optional (defaults *default-pathname-defaults*)) - "Return a list of all files which are possible completions of Pathname. +(defun ambiguous-files (pathname + &optional (defaults *default-pathname-defaults*)) + "Return a list of all files which are possible completions of Pathname. We look in the directory specified by Defaults as well as looking down the search list." - (complete-file-directory pathname defaults)) ) - - -;;;; CLISP fixage - -#+CLISP -(in-package :xlib) - -#+CLISP -'(progn - (defvar *lookahead* nil) - - (setf *buffer-read-polling-time* .01) - - (defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (declare (values timeout)) - - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) nil) - ((eql timeout 0) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - - (defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) - ;; #.(declare-buffun) - (let ((stream (display-input-stream display))) - (cond ((and (eql timeout 0) - (not (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream)))) ) - :timeout) - (t - (if *lookahead* - (progn - (setf (aref vector start) *lookahead*) - (setf *lookahead* nil) - (system::read-n-bytes stream vector (+ start 1) (- end start 1))) - (system::read-n-bytes stream vector start (- end start))) - nil)) ) ) ) + (complete-file-directory pathname defaults)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp (revision 7993) @@ -96,5 +96,5 @@ came from, and sets (current-open-line) to Nil." (when (current-open-line) - (hemlock-ext:without-interrupts + (without-interrupts (let* ((open-chars (current-open-chars)) (right-pos (current-right-open-pos)) @@ -203,5 +203,5 @@ (invoke-hook hemlock::buffer-modified-hook ,b t)) (setf (buffer-modified ,b) t)) - (hemlock-ext:without-interrupts ,@forms)))) + (without-interrupts ,@forms)))) (defmacro always-change-line (mark new-line) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp (revision 7993) @@ -97,6 +97,5 @@ (let ((key-event (aref key try-pos))) (vector-push-extend - (hemlock-ext:make-key-event key-event (logior (hemlock-ext:key-event-bits key-event) - prefix)) + (make-key-event key-event (logior (key-event-bits key-event) prefix)) temp) (setf prefix 0)) @@ -138,5 +137,5 @@ ((or simple-vector null) entry) (integer - (cons :bits (hemlock-ext:key-event-bits-modifiers entry)))))) + (cons :bits (key-event-bits-modifiers entry)))))) ;;; %SET-KEY-TRANSLATION -- Internal @@ -144,5 +143,5 @@ (defun %set-key-translation (key new-value) (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits)) - (apply #'hemlock-ext:make-key-event-bits (cdr new-value))) + (apply #'make-key-event-bits (cdr new-value))) (new-value (crunch-key new-value)) (t new-value)))) @@ -190,9 +189,9 @@ (defun crunch-key (key) (typecase key - (hemlock-ext:key-event (vector key)) + (key-event (vector key)) ((or list vector) ;List thrown in gratuitously. (when (zerop (length key)) (error "A zero length key is illegal.")) - (unless (every #'hemlock-ext:key-event-p key) + (unless (every #'key-event-p key) (error "A Key ~S must contain only key-events." key)) (coerce key 'simple-vector)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp (revision 7993) @@ -1,3 +1,3 @@ -;;; -*- Log: hemlock.log; Package: HEMLOCK-EXT -*- +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** @@ -10,26 +10,28 @@ ;;; ********************************************************************** ;;; -;;; This file implements key-events for representing editor input. It also -;;; provides a couple routines to interface this to X11. +;;; This file implements key-events for representing editor input. ;;; ;;; Written by Blaine Burks and Bill Chiles. ;;; -;;; The following are the implementation dependent parts of this code (what -;;; you would have to change if you weren't using X11): -;;; *modifier-translations* -;;; DEFINE-MODIFIER-BIT -;;; TRANSLATE-KEY-EVENT -;;; TRANSLATE-MOUSE-KEY-EVENT -;;; DEFINE-KEYSYM -;;; DEFINE-MOUSE-KEYSYM -;;; DO-ALPHA-KEY-EVENTS -;;; If the window system didn't use a keysym mechanism to represent keys, you -;;; would also need to write something that mapped whatever did encode the -;;; keys to the keysyms defined with DEFINE-KEYSYM. -;;; - -(in-package :hemlock-ext) - +(in-package :hemlock-internals) + + + +;;; Objects involved in key events: +;;; (1) a KEY-EVENT describes a combination of a KEYSYM and MODIFIERS. KEY-EVENTS +;;; are interned, so there is a unique key-event for each combination of keysym and +;;; modifiers. +;;; (2) A KEYSYM is an object representing a key. It must be declared to be so via +;;; define-keysym. A KEYSYM must be defined before a key-event based on it can be +;;; defined. +;;; (3) A CODE is a system-dependent fixnum value for a KEYSYM. It must be defined +;;; before any events actually occur, but it doesn't need to be defined in order to +;;; create key-events. +;;; +;;; The Keysym can be the same as a code, but separating them deals with a bootstrapping +;;; problem: keysyms cannot be defined before hemlock is loaded, but hemlock wants to +;;; define key events while it's loading. So we define key events using keysyms, and let +;;; their codes be defined later @@ -81,5 +83,5 @@ (if (= (length string) 1) string (string-downcase string))) -;;; DEFINE-KEYSYM -- Public. +;;; DEFINE-KEYSYM -- Public ;;; (defun define-keysym (keysym preferred-name &rest other-names) @@ -94,7 +96,6 @@ ;;; This is an a-list mapping native modifier bit masks to defined key-event -;;; modifier names. DEFINE-MODIFIER-BIT fills this in, so TRANSLATE-KEY-EVENT -;;; and TRANSLATE-MOUSE-KEY-EVENT can work. -;;; +;;; modifier names. +;;; (defvar *modifier-translations*) @@ -195,7 +196,5 @@ ;;; (defun define-mouse-keysym (button keysym name shifted-bit event-key) - "This defines keysym named name for the X button cross the X event-key. - Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets - in the key-event it returns whenever the X shift bit is on." + "This defines keysym named name for the X button cross the X event-key." (unless (<= 1 button 5) (error "Buttons are number 1-5, not ~D." button)) @@ -216,10 +215,10 @@ (:constructor %make-key-event (keysym bits))) (bits nil :type fixnum) - (keysym nil :type fixnum)) + (keysym nil)) (defun %print-key-event (object stream ignore) (declare (ignore ignore)) (write-string "# stream)) @@ -227,5 +226,5 @@ ;;; syntax. ;;; -(defvar *key-character-classes* (make-array char-code-limit +(defvar *key-character-classes* (make-array hemlock-char-code-limit :initial-element :other)) @@ -262,5 +261,5 @@ ;;; form. Since key-events are unique at runtime, we cannot create them at ;;; readtime, returning the constant object from READ. Wherever a #k appears, -;;; there's a for that at loadtime or runtime will return the unique key-event +;;; there's a form that at loadtime or runtime will return the unique key-event ;;; or vector of unique key-events. ;;; @@ -274,5 +273,5 @@ (error "Keys must be delimited by ~S." #\")) ;; Skip any leading spaces in the string. - (skip-whitespace stream) + (peek-char t stream) (multiple-value-setq (char class) (get-key-char stream)) (ecase class @@ -297,5 +296,5 @@ (setf bits 0) ;; Skip any whitespace between characters. - (skip-whitespace stream) + (peek-char t stream) (multiple-value-setq (char class) (get-key-char stream)) (ecase class @@ -374,6 +373,4 @@ "A list of all the names of defined modifiers.") -;;; DEFINE-KEY-EVENT-MODIFIER -- Public. -;;; ;;; Note that short-name is pushed into *modifiers-to-internal-masks* after ;;; long-name. PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on @@ -415,7 +412,5 @@ ;;; (defun define-modifier-bit (bit-mask modifier-name) - "This establishes a mapping from bit-mask to a define key-event modifier-name. - TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events - with bits defined by this routine." + "This establishes a mapping from bit-mask to a define key-event modifier-name." (let ((map (assoc modifier-name *modifiers-to-internal-masks* :test #'string-equal))) @@ -429,6 +424,4 @@ ;;; -;;; MAKE-KEY-EVENT-BITS -- Public. -;;; (defun make-key-event-bits (&rest modifier-names) "This returns bits suitable for MAKE-KEY-EVENT from the supplied modifier @@ -468,7 +461,5 @@ ;;;; Key event lookup -- GET-KEY-EVENT and MAKE-KEY-EVENT. -(defvar *keysym-high-bytes*) - -(defconstant modifier-bits-limit (ash 1 modifier-count-limit)) +(defvar *key-events*) ;;; GET-KEY-EVENT -- Internal. @@ -480,5 +471,5 @@ ;;; (defun get-key-event* (keysym bits) - (let* ((char (code-char keysym))) + (let* ((char (and (fixnump keysym) (code-char keysym)))) (when (and char (standard-char-p char)) (let* ((mask (key-event-modifier-mask "Shift"))) @@ -486,23 +477,23 @@ (setq bits (logandc2 bits mask) keysym (char-code (char-upcase char))))))) - (let* ((high-byte (ash keysym -8)) - (low-byte-vector (svref *keysym-high-bytes* high-byte))) - (unless low-byte-vector - (let ((new-vector (make-array 256 :initial-element nil))) - (setf (svref *keysym-high-bytes* high-byte) new-vector) - (setf low-byte-vector new-vector))) - (let* ((low-byte (ldb (byte 8 0) keysym)) - (bit-vector (svref low-byte-vector low-byte))) - (unless bit-vector - (let ((new-vector (make-array modifier-bits-limit - :initial-element nil))) - (setf (svref low-byte-vector low-byte) new-vector) - (setf bit-vector new-vector))) - (let ((key-event (svref bit-vector bits))) - (if key-event - key-event - (setf (svref bit-vector bits) (%make-key-event keysym bits))))))) - -;;; MAKE-KEY-EVENT -- Public. + (let* ((data (cons keysym bits))) + (or (gethash data *key-events*) + (setf (gethash data *key-events*) (%make-key-event keysym bits))))) + +;;; +(defvar *keysym-to-code*) +(defvar *code-to-keysym*) + +(defmacro define-keysym-code (keysym code) + `(progn + (setf (gethash ,keysym *keysym-to-code*) ,code) + (setf (gethash ,code *code-to-keysym*) ,keysym))) + +(defun keysym-for-code (code) + (or (gethash code *code-to-keysym*) code)) + +(defun code-for-keysym (keysym) + (or (gethash keysym *keysym-to-code*) (and (fixnump keysym) keysym))) + ;;; (defun make-key-event (object &optional (bits 0)) @@ -513,7 +504,8 @@ (etypecase object (integer - (unless (keysym-names object) - (error "~S is an undefined keysym." object)) - (get-key-event* object bits)) + (let ((keysym (keysym-for-code object))) + (unless (keysym-names keysym) + (error "~S is an undefined code." object)) + (get-key-event* keysym bits))) #|(character (let* ((name (char-name object)) @@ -555,5 +547,5 @@ (check-type key-event key-event) (or (gethash key-event *key-event-characters*) - (code-char (key-event-keysym key-event)))) + (code-char (code-for-keysym (key-event-keysym key-event))))) (defun %set-key-event-char (key-event character) @@ -618,5 +610,5 @@ ;;;; PRINT-PRETTY-KEY and PRINT-PRETTY-KEY-EVENT. -;;; PRINT-PRETTY-KEY -- Public. +;;; PRINT-PRETTY-KEY -- Internal ;;; (defun print-pretty-key (key &optional (stream *standard-output*) long-names-p) @@ -624,5 +616,4 @@ user-expected fashion. Long-names-p indicates whether modifiers should print with their long or short name." - (declare (type (or vector key-event) key) (type stream stream)) (etypecase key (key-event (print-pretty-key-event key stream long-names-p)) @@ -634,5 +625,5 @@ (unless (= i length-1) (write-char #\space stream)))))))) -;;; PRINT-PRETTY-KEY-EVENT -- Public. +;;; PRINT-PRETTY-KEY-EVENT -- Internal ;;; ;;; Note, this makes use of the ordering in the a-list @@ -658,5 +649,9 @@ (when spacep (write-char #\> stream)))) - +;;; PRETTY-KEY-STRING - Public. +;;; +(defun pretty-key-string (key &optional long-names-p) + (with-output-to-string (s) + (print-pretty-key key s long-names-p))) @@ -676,4 +671,6 @@ (setf *keysyms-to-names* (make-hash-table :test #'eql)) (setf *names-to-keysyms* (make-hash-table :test #'equal)) + (setf *keysym-to-code* (make-hash-table :test #'eql)) + (setf *code-to-keysym* (make-hash-table :test #'eql)) (setf *modifier-translations* ()) (setf *modifiers-to-internal-masks* ()) @@ -681,8 +678,8 @@ (setf *modifier-count* 0) (setf *all-modifier-names* ()) - (setf *keysym-high-bytes* (make-array 256 :initial-element nil)) + (setf *key-events* (make-hash-table :test #'equal)) (setf *key-event-characters* (make-hash-table)) (setf *character-key-events* - (make-array char-code-limit :initial-element nil)) + (make-array hemlock-char-code-limit :initial-element nil)) (define-key-event-modifier "Hyper" "H") Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/keysym-defs.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/keysym-defs.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/keysym-defs.lisp (revision 7993) @@ -10,157 +10,139 @@ ;;; ********************************************************************** ;;; -;;; This file defines all the definitions of keysyms (see key-event.lisp). -;;; These keysyms match those for X11. ;;; ;;; Written by Bill Chiles ;;; Modified by Blaine Burks. ;;; +;;; This file defines all the "portable" keysyms. (in-package :hemlock-internals) +;;; "Named" keys. +;;; +(define-keysym 9 "Tab") +(define-keysym 27 "Escape" "Altmode" "Alt") ;escape +(define-keysym 127 "Delete" "Backspace") ;backspace +(define-keysym 13 "Return" "Newline") +(define-keysym 10 "LineFeed") +(define-keysym 3 "Enter") +(define-keysym 32 "Space" " ") + +;;; Letters. +;;; +(define-keysym 97 "a") (define-keysym 65 "A") +(define-keysym 98 "b") (define-keysym 66 "B") +(define-keysym 99 "c") (define-keysym 67 "C") +(define-keysym 100 "d") (define-keysym 68 "D") +(define-keysym 101 "e") (define-keysym 69 "E") +(define-keysym 102 "f") (define-keysym 70 "F") +(define-keysym 103 "g") (define-keysym 71 "G") +(define-keysym 104 "h") (define-keysym 72 "H") +(define-keysym 105 "i") (define-keysym 73 "I") +(define-keysym 106 "j") (define-keysym 74 "J") +(define-keysym 107 "k") (define-keysym 75 "K") +(define-keysym 108 "l") (define-keysym 76 "L") +(define-keysym 109 "m") (define-keysym 77 "M") +(define-keysym 110 "n") (define-keysym 78 "N") +(define-keysym 111 "o") (define-keysym 79 "O") +(define-keysym 112 "p") (define-keysym 80 "P") +(define-keysym 113 "q") (define-keysym 81 "Q") +(define-keysym 114 "r") (define-keysym 82 "R") +(define-keysym 115 "s") (define-keysym 83 "S") +(define-keysym 116 "t") (define-keysym 84 "T") +(define-keysym 117 "u") (define-keysym 85 "U") +(define-keysym 118 "v") (define-keysym 86 "V") +(define-keysym 119 "w") (define-keysym 87 "W") +(define-keysym 120 "x") (define-keysym 88 "X") +(define-keysym 121 "y") (define-keysym 89 "Y") +(define-keysym 122 "z") (define-keysym 90 "Z") + +;;; Standard number keys. +;;; +(define-keysym 49 "1") (define-keysym 33 "!") +(define-keysym 50 "2") (define-keysym 64 "@") +(define-keysym 51 "3") (define-keysym 35 "#") +(define-keysym 52 "4") (define-keysym 36 "$") +(define-keysym 53 "5") (define-keysym 37 "%") +(define-keysym 54 "6") (define-keysym 94 "^") +(define-keysym 55 "7") (define-keysym 38 "&") +(define-keysym 56 "8") (define-keysym 42 "*") +(define-keysym 57 "9") (define-keysym 40 "(") +(define-keysym 48 "0") (define-keysym 41 ")") + +;;; "Standard" symbol keys. +;;; +(define-keysym 96 "`") (define-keysym 126 "~") +(define-keysym 45 "-") (define-keysym 95 "_") +(define-keysym 61 "=") (define-keysym 43 "+") +(define-keysym 91 "[") (define-keysym 123 "{") +(define-keysym 93 "]") (define-keysym 125 "}") +(define-keysym 92 "\\") (define-keysym 124 "|") +(define-keysym 59 ";") (define-keysym 58 ":") +(define-keysym 39 "'") (define-keysym 34 "\"") +(define-keysym 44 ",") (define-keysym 60 "<") +(define-keysym 46 ".") (define-keysym 62 ">") +(define-keysym 47 "/") (define-keysym 63 "?") - -;;; Function keys for the RT. -;;; - -;;; This isn't the RT. -(eval-when (:compile-toplevel :execute) - (ccl::use-interface-dir :cocoa)) - -(hemlock-ext:define-keysym #$NSF1FunctionKey "F1") -(hemlock-ext:define-keysym #$NSF2FunctionKey "F2") -(hemlock-ext:define-keysym #$NSF3FunctionKey "F3") -(hemlock-ext:define-keysym #$NSF4FunctionKey "F4") -(hemlock-ext:define-keysym #$NSF5FunctionKey "F5") -(hemlock-ext:define-keysym #$NSF6FunctionKey "F6") -(hemlock-ext:define-keysym #$NSF7FunctionKey "F7") -(hemlock-ext:define-keysym #$NSF8FunctionKey "F8") -(hemlock-ext:define-keysym #$NSF9FunctionKey "F9") -(hemlock-ext:define-keysym #$NSF10FunctionKey "F10") -(hemlock-ext:define-keysym #$NSF11FunctionKey "F11") -(hemlock-ext:define-keysym #$NSF12FunctionKey "F12") -(hemlock-ext:define-keysym #$NSF13FunctionKey "F13") -(hemlock-ext:define-keysym #$NSF14FunctionKey "F14") -(hemlock-ext:define-keysym #$NSF15FunctionKey "F15") -(hemlock-ext:define-keysym #$NSF16FunctionKey "F16") -(hemlock-ext:define-keysym #$NSF17FunctionKey "F17") -(hemlock-ext:define-keysym #$NSF18FunctionKey "F18") -(hemlock-ext:define-keysym #$NSF19FunctionKey "F19") -(hemlock-ext:define-keysym #$NSF20FunctionKey "F20") -(hemlock-ext:define-keysym #$NSF21FunctionKey "F21") -(hemlock-ext:define-keysym #$NSF22FunctionKey "F22") -(hemlock-ext:define-keysym #$NSF23FunctionKey "F23") -(hemlock-ext:define-keysym #$NSF24FunctionKey "F24") -(hemlock-ext:define-keysym #$NSF25FunctionKey "F25") -(hemlock-ext:define-keysym #$NSF26FunctionKey "F26") -(hemlock-ext:define-keysym #$NSF27FunctionKey "F27") -(hemlock-ext:define-keysym #$NSF28FunctionKey "F28") -(hemlock-ext:define-keysym #$NSF29FunctionKey "F29") -(hemlock-ext:define-keysym #$NSF30FunctionKey "F30") -(hemlock-ext:define-keysym #$NSF31FunctionKey "F31") -(hemlock-ext:define-keysym #$NSF32FunctionKey "F32") -(hemlock-ext:define-keysym #$NSF33FunctionKey "F33") -(hemlock-ext:define-keysym #$NSF34FunctionKey "F34") -(hemlock-ext:define-keysym #$NSF35FunctionKey "F35") - +(define-keysym :F1 "F1") +(define-keysym :F2 "F2") +(define-keysym :F3 "F3") +(define-keysym :F4 "F4") +(define-keysym :F5 "F5") +(define-keysym :F6 "F6") +(define-keysym :F7 "F7") +(define-keysym :F8 "F8") +(define-keysym :F9 "F9") +(define-keysym :F10 "F10") +(define-keysym :F11 "F11") +(define-keysym :F12 "F12") +(define-keysym :F13 "F13") +(define-keysym :F14 "F14") +(define-keysym :F15 "F15") +(define-keysym :F16 "F16") +(define-keysym :F17 "F17") +(define-keysym :F18 "F18") +(define-keysym :F19 "F19") +(define-keysym :F20 "F20") +(define-keysym :F21 "F21") +(define-keysym :F22 "F22") +(define-keysym :F23 "F23") +(define-keysym :F24 "F24") +(define-keysym :F25 "F25") +(define-keysym :F26 "F26") +(define-keysym :F27 "F27") +(define-keysym :F28 "F28") +(define-keysym :F29 "F29") +(define-keysym :F30 "F30") +(define-keysym :F31 "F31") +(define-keysym :F32 "F32") +(define-keysym :F33 "F33") +(define-keysym :F34 "F34") +(define-keysym :F35 "F35") ;;; Upper right key bank. ;;; -(hemlock-ext:define-keysym #$NSPrintScreenFunctionKey "Printscreen") +(define-keysym :printscreen "Printscreen") ;; Couldn't type scroll lock. -(hemlock-ext:define-keysym #$NSPauseFunctionKey "Pause") +(define-keysym :pause "Pause") ;;; Middle right key bank. ;;; -(hemlock-ext:define-keysym #$NSInsertFunctionKey "Insert") -(hemlock-ext:define-keysym #$NSDeleteFunctionKey "Del" "Rubout" (string (code-char 127))) -(hemlock-ext:define-keysym #$NSHomeFunctionKey "Home") -(hemlock-ext:define-keysym #$NSPageUpFunctionKey "Pageup") -(hemlock-ext:define-keysym #$NSEndFunctionKey "End") -(hemlock-ext:define-keysym #$NSPageDownFunctionKey "Pagedown") +(define-keysym :insert "Insert") +(define-keysym :del "Del" "Rubout" (string (code-char 127))) +(define-keysym :home "Home") +(define-keysym :pageup "Pageup") +(define-keysym :end "End") +(define-keysym :pagedown "Pagedown") ;;; Arrows. ;;; -(hemlock-ext:define-keysym #$NSLeftArrowFunctionKey "Leftarrow") -(hemlock-ext:define-keysym #$NSUpArrowFunctionKey "Uparrow") -(hemlock-ext:define-keysym #$NSDownArrowFunctionKey "Downarrow") -(hemlock-ext:define-keysym #$NSRightArrowFunctionKey "Rightarrow") +(define-keysym :leftarrow "Leftarrow") +(define-keysym :uparrow "Uparrow") +(define-keysym :downarrow "Downarrow") +(define-keysym :rightarrow "Rightarrow") -;;; "Named" keys. -;;; -(hemlock-ext:define-keysym 9 "Tab") -(hemlock-ext:define-keysym 27 "Escape" "Altmode" "Alt") ;escape -(hemlock-ext:define-keysym 127 "Delete" "Backspace") ;backspace -(hemlock-ext:define-keysym 13 "Return" "Newline") -(hemlock-ext:define-keysym 10 "LineFeed") -(hemlock-ext:define-keysym 3 "Enter") -(hemlock-ext:define-keysym 32 "Space" " ") - -;;; Letters. -;;; -(hemlock-ext:define-keysym 97 "a") (hemlock-ext:define-keysym 65 "A") -(hemlock-ext:define-keysym 98 "b") (hemlock-ext:define-keysym 66 "B") -(hemlock-ext:define-keysym 99 "c") (hemlock-ext:define-keysym 67 "C") -(hemlock-ext:define-keysym 100 "d") (hemlock-ext:define-keysym 68 "D") -(hemlock-ext:define-keysym 101 "e") (hemlock-ext:define-keysym 69 "E") -(hemlock-ext:define-keysym 102 "f") (hemlock-ext:define-keysym 70 "F") -(hemlock-ext:define-keysym 103 "g") (hemlock-ext:define-keysym 71 "G") -(hemlock-ext:define-keysym 104 "h") (hemlock-ext:define-keysym 72 "H") -(hemlock-ext:define-keysym 105 "i") (hemlock-ext:define-keysym 73 "I") -(hemlock-ext:define-keysym 106 "j") (hemlock-ext:define-keysym 74 "J") -(hemlock-ext:define-keysym 107 "k") (hemlock-ext:define-keysym 75 "K") -(hemlock-ext:define-keysym 108 "l") (hemlock-ext:define-keysym 76 "L") -(hemlock-ext:define-keysym 109 "m") (hemlock-ext:define-keysym 77 "M") -(hemlock-ext:define-keysym 110 "n") (hemlock-ext:define-keysym 78 "N") -(hemlock-ext:define-keysym 111 "o") (hemlock-ext:define-keysym 79 "O") -(hemlock-ext:define-keysym 112 "p") (hemlock-ext:define-keysym 80 "P") -(hemlock-ext:define-keysym 113 "q") (hemlock-ext:define-keysym 81 "Q") -(hemlock-ext:define-keysym 114 "r") (hemlock-ext:define-keysym 82 "R") -(hemlock-ext:define-keysym 115 "s") (hemlock-ext:define-keysym 83 "S") -(hemlock-ext:define-keysym 116 "t") (hemlock-ext:define-keysym 84 "T") -(hemlock-ext:define-keysym 117 "u") (hemlock-ext:define-keysym 85 "U") -(hemlock-ext:define-keysym 118 "v") (hemlock-ext:define-keysym 86 "V") -(hemlock-ext:define-keysym 119 "w") (hemlock-ext:define-keysym 87 "W") -(hemlock-ext:define-keysym 120 "x") (hemlock-ext:define-keysym 88 "X") -(hemlock-ext:define-keysym 121 "y") (hemlock-ext:define-keysym 89 "Y") -(hemlock-ext:define-keysym 122 "z") (hemlock-ext:define-keysym 90 "Z") - -;;; Standard number keys. -;;; -(hemlock-ext:define-keysym 49 "1") (hemlock-ext:define-keysym 33 "!") -(hemlock-ext:define-keysym 50 "2") (hemlock-ext:define-keysym 64 "@") -(hemlock-ext:define-keysym 51 "3") (hemlock-ext:define-keysym 35 "#") -(hemlock-ext:define-keysym 52 "4") (hemlock-ext:define-keysym 36 "$") -(hemlock-ext:define-keysym 53 "5") (hemlock-ext:define-keysym 37 "%") -(hemlock-ext:define-keysym 54 "6") (hemlock-ext:define-keysym 94 "^") -(hemlock-ext:define-keysym 55 "7") (hemlock-ext:define-keysym 38 "&") -(hemlock-ext:define-keysym 56 "8") (hemlock-ext:define-keysym 42 "*") -(hemlock-ext:define-keysym 57 "9") (hemlock-ext:define-keysym 40 "(") -(hemlock-ext:define-keysym 48 "0") (hemlock-ext:define-keysym 41 ")") - -;;; "Standard" symbol keys. -;;; -(hemlock-ext:define-keysym 96 "`") (hemlock-ext:define-keysym 126 "~") -(hemlock-ext:define-keysym 45 "-") (hemlock-ext:define-keysym 95 "_") -(hemlock-ext:define-keysym 61 "=") (hemlock-ext:define-keysym 43 "+") -(hemlock-ext:define-keysym 91 "[") (hemlock-ext:define-keysym 123 "{") -(hemlock-ext:define-keysym 93 "]") (hemlock-ext:define-keysym 125 "}") -(hemlock-ext:define-keysym 92 "\\") (hemlock-ext:define-keysym 124 "|") -(hemlock-ext:define-keysym 59 ";") (hemlock-ext:define-keysym 58 ":") -(hemlock-ext:define-keysym 39 "'") (hemlock-ext:define-keysym 34 "\"") -(hemlock-ext:define-keysym 44 ",") (hemlock-ext:define-keysym 60 "<") -(hemlock-ext:define-keysym 46 ".") (hemlock-ext:define-keysym 62 ">") -(hemlock-ext:define-keysym 47 "/") (hemlock-ext:define-keysym 63 "?") - - -(hemlock-ext::define-mouse-keysym 1 #xe000 "Leftdown" "Super" :button-press) - -;;; - -;(hemlock-ext:define-keysym 65290 "linefeed") - - +(define-mouse-keysym 1 #xe000 "Leftdown" "Super" :button-press) @@ -184,12 +166,12 @@ (let ((@-code (char-code #\@))) (dotimes (i (char-code #\space)) - (setf (hemlock-ext:char-key-event (code-char i)) - (hemlock-ext::make-key-event (string (char-downcase (code-char (+ i @-code)))) - (hemlock-ext:key-event-modifier-mask "control"))))) -(setf (hemlock-ext:char-key-event (code-char 9)) (hemlock-ext::make-key-event #k"Tab")) -(setf (hemlock-ext:char-key-event (code-char 10)) (hemlock-ext::make-key-event #k"Linefeed")) -(setf (hemlock-ext:char-key-event (code-char 13)) (hemlock-ext::make-key-event #k"Return")) -(setf (hemlock-ext:char-key-event (code-char 27)) (hemlock-ext::make-key-event #k"Alt")) -(setf (hemlock-ext:char-key-event (code-char 8)) (hemlock-ext::make-key-event #k"Backspace")) + (setf (char-key-event (code-char i)) + (make-key-event (string (char-downcase (code-char (+ i @-code)))) + (key-event-modifier-mask "control"))))) +(setf (char-key-event (code-char 9)) (make-key-event #k"Tab")) +(setf (char-key-event (code-char 10)) (make-key-event #k"Linefeed")) +(setf (char-key-event (code-char 13)) (make-key-event #k"Return")) +(setf (char-key-event (code-char 27)) (make-key-event #k"Alt")) +(setf (char-key-event (code-char 8)) (make-key-event #k"Backspace")) ;;; ;;; Other ASCII codes are exactly the same as the Common Lisp codes. @@ -197,6 +179,6 @@ (do ((i (char-code #\space) (1+ i))) ((= i 128)) - (setf (hemlock-ext:char-key-event (code-char i)) - (hemlock-ext::make-key-event (string (code-char i))))) + (setf (char-key-event (code-char i)) + (make-key-event (string (code-char i))))) ;;; This makes KEY-EVENT-CHAR the inverse of CHAR-KEY-EVENT from the start. @@ -205,12 +187,12 @@ (dotimes (i 128) (let ((character (code-char i))) - (setf (hemlock-ext::key-event-char (hemlock-ext:char-key-event character)) character))) + (setf (key-event-char (char-key-event character)) character))) ;;; Since we treated these characters specially above when setting -;;; HEMLOCK-EXT:CHAR-KEY-EVENT above, we must set these HEMLOCK-EXT:KEY-EVENT-CHAR's specially +;;; CHAR-KEY-EVENT above, we must set these KEY-EVENT-CHAR's specially ;;; to make quoting characters into Hemlock buffers more obvious for users. ;;; -(setf (hemlock-ext:key-event-char #k"C-h") #\backspace) -(setf (hemlock-ext:key-event-char #k"C-i") #\tab) -(setf (hemlock-ext:key-event-char #k"C-j") #\linefeed) -(setf (hemlock-ext:key-event-char #k"C-m") #\return) +(setf (key-event-char #k"C-h") #\backspace) +(setf (key-event-char #k"C-i") #\tab) +(setf (key-event-char #k"C-j") #\linefeed) +(setf (key-event-char #k"C-m") #\return) Index: anches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp (revision 7992) +++ (revision ) @@ -1,62 +1,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: HEMLOCK-EXT; -*- -;;; --------------------------------------------------------------------------- -;;; Title: Lisp Implementation Dependent Stuff for Hemlock -;;; Created: 2002-11-07 -;;; Author: Gilbert Baumann -;;; --------------------------------------------------------------------------- -;;; (c) copyright 2002 by Gilbert Baumann - -(in-package :hemlock-ext) - -(defun getenv (name) - #.(or - #+EXCL '(sys:getenv name) - #+CLISP '(ext:getenv name) - #+CMU '(cdr (assoc name ext:*environment-list* :test #'string=)) - #+scl '(cdr (assoc name ext:*environment-list* :test #'string-equal)) - #+sbcl '(sb-ext:posix-getenv name) - #+openmcl '(ccl::getenv name) - (error "Find an implementation of getenv for your Lisp."))) - -(defmacro without-interrupts (&body body) - `(#+EXCL excl:without-interrupts - #+CMU sys:without-interrupts - #+sbcl sb-sys:without-interrupts - #+openmcl ccl:without-interrupts - #-(or EXCL CMU sbcl openmcl) progn - ,@body)) - -(defmacro fixnump (object) - #+CMU `(ext:fixnump ,object) - #+scl `(ext:fixnump ,object) - #+EXCL `(excl:fixnump ,object) - #+CLISP `(sys::fixnump ,object) - #-(or CMU EXCL CLISP scl) `(typep ,object 'fixnum)) - -(defun file-writable (pathname) - "File-writable accepts a pathname and returns T if the current - process can write it, and NIL otherwise. Also if the file does - not exist return T." - #+(or CMU scl) - (ext:file-writable pathname) - #-(or cmu scl) - (handler-case (let ((io (open pathname - :direction :output - :if-exists :append - :if-does-not-exist nil))) - (if io - (close io :abort t) - ;; more complicate situation: - ;; we want test if we can create the file. - (let ((io (open pathname - :direction :output - :if-exists nil - :if-does-not-exist :create))) - (if io - (progn - (close io) - (delete-file io)) - t)))) - (file-error (err) - (declare (ignore err)) - nil)) ) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 7993) @@ -78,12 +78,16 @@ (defmacro with-buffer-bindings ((buffer) &body body) - (let ((buffer-var (gensym))) - `(let ((,buffer-var ,buffer) - ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var)))) + (let ((buffer-var (gensym)) + (setup-p (gensym))) + `(let* ((,buffer-var ,buffer) + (,setup-p nil) + ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var)))) (unwind-protect (progn - (setup-buffer-bindings ,buffer-var) + (unless (buffer-bindings-wound-p ,buffer-var) + (setup-buffer-bindings ,buffer-var) + (setq ,setup-p t)) ,@body) - (revert-buffer-bindings ,buffer-var))))) + (when ,setup-p (revert-buffer-bindings ,buffer-var)))))) @@ -418,6 +422,6 @@ ) Each tag is either a character or a logical key-event. The user's typed - key-event is compared using either EXT:LOGICAL-KEY-EVENT-P or CHAR= of - EXT:KEY-EVENT-CHAR. + key-event is compared using either LOGICAL-KEY-EVENT-P or CHAR= of + KEY-EVENT-CHAR. The legal keys of the key/value pairs are :help, :prompt, and :bind." @@ -436,10 +440,10 @@ (setf ,',bind (prompt-for-key-event :prompt ,',n-prompt)) - (setf ,',bind-char (hemlock-ext:key-event-char ,',bind)) + (setf ,',bind-char (key-event-char ,',bind)) (go ,',again)))) (block ,bname (let* ((,n-prompt ,prompt) (,bind (prompt-for-key-event :prompt ,n-prompt)) - (,bind-char (hemlock-ext:key-event-char ,bind))) + (,bind-char (key-event-char ,bind))) (declare (ignorable,bind ,bind-char)) (tagbody Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp (revision 7993) @@ -16,14 +16,4 @@ (in-package :hemlock-internals) - -#|| -GB -(in-package :extensions) -(export '(save-all-buffers *hemlock-version*)) -(in-package :hemlock-internals) -||# - - - ;;;; Definition of *hemlock-version*. Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 7993) @@ -102,5 +102,5 @@ (let ((val (variable-value 'hemlock::current-package :buffer buffer))) - (if val + (if (stringp val) (if (find-package val) (format nil "~A: " val) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp (revision 7993) @@ -210,8 +210,9 @@ :help "Name of command to bind to a key.")) (values (prompt-for-key - :prompt "Bind to: " :must-exist nil + :must-exist nil + :prompt "Bind to: " :help "Key to bind command to, confirm to complete.")) (prompt-for-place "Kind of binding: " - "The kind of binding to make."))) + "The kind of binding to make."))) (defcommand "Delete Key Binding" (p) @@ -221,5 +222,6 @@ (declare (ignore p)) (let ((key (prompt-for-key - :prompt "Delete binding: " :must-exist nil + :must-exist nil + :prompt "Delete binding: " :help "Key to delete binding from."))) (multiple-value-bind (kind where) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7993) @@ -1,15 +1,3 @@ (in-package :cl-user) - -;; Note: I want real relative package names like the Symbolics has -;; them. In the mean time: - -#+CMU -(eval-when (:compile-toplevel :load-toplevel :execute) - (progn - ;; Just in case the original Hemlock is loaded. - (dolist (p '("HEMLOCK" "HEMLOCK-INTERNALS")) - (when (find-package p) - (delete-package p))))) - (defpackage :hemlock-interface @@ -301,56 +289,11 @@ )) +;; Functions defined externally (i.e. used by but not defined in hemlock). In theory, +;; these (and codes for the symbolic keysyms in keysym-defs.lisp, q.v.) is all you need +;; to implement to port the IDE to a different window system. (defpackage :hemlock-ext - (:use :common-lisp - :hemlock-interface) - #+cmu - (:import-from :ext #:complete-file) - (:shadow #:char-code-limit) - #+clozure - (:import-from :ccl #:memq #:assq #:delq) - #+clozure - (:import-from :gui #:log-debug) + (:use) ;; (:export - #:file-comment - #:without-interrupts - #:define-setf-method - #:getenv - #:delq #:memq #:assq - #:fixnump - #:file-writable - - ;; key-event.lisp - #:define-keysym - #:define-mouse-keysym - #:name-keysym - #:keysym-names - #:keysym-preferred-name - #:define-key-event-modifier - #:define-modifier-bit - #:make-key-event-bits - #:key-event-modifier-mask - #:key-event-bits-modifiers - #:*all-modifier-names* - #:translate-key-event - #:translate-mouse-key-event - #:make-key-event - #:key-event - #:key-event-p - #:key-event-bits - #:key-event-keysym - #:char-key-event - #:key-event-char - #:key-event-bit-p - #:do-alpha-key-events - #:print-pretty-key - #:print-pretty-key-event - - ;; hemlock-ext.lisp - #:complete-file - #:default-directory - - ;; defined externally (i.e. used by but not defined in hemlock). These are the - ;; things that would need to be implemented to port to a different window system. #:invoke-modifying-buffer-storage #:note-selection-set-by-search @@ -374,5 +317,4 @@ (:use :common-lisp :hemlock-interface) (:nicknames :hemlock-internals) - (:shadow #:char-code-limit) (:import-from ;; gray streams @@ -384,5 +326,5 @@ #+clozure :gray ;; - ;; Note the pacth i received from DTC mentions character-output and + ;; Note the patch i received from DTC mentions character-output and ;; character-input-stream here, so we actually see us faced to ;; provide for compatibility classes. --GB @@ -402,11 +344,24 @@ #:stream-force-output #:stream-line-column) - (:import-from :hemlock-ext + (:import-from :ccl #:delq #:memq #:assq - #+clozure #:log-debug) + #:getenv + #:fixnump) + (:import-from :gui + #:log-debug) + ;; ** TODO: get rid of this. The code that uses it assumes it guarantees atomicity, + ;; and it doesn't. + (:import-from :ccl #:without-interrupts) ;; (:export #:*FAST* ;hmm not sure about this one + ;; Imported + #:delq #:memq #:assq #:getenv #:fixnump #:log-debug + + ;; hemlock-ext.lisp + #:hemlock-char-code-limit + #:file-writable #:default-directory #:complete-file #:ambiguous-files + ;; rompsite.lisp #:show-mark #:fun-defined-from-pathname @@ -443,4 +398,5 @@ #:hemlock-view #:current-view #:hemlock-view-buffer #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed + #:invoke-command #:abort-to-toplevel #:abort-current-command #:set-scroll-position @@ -477,4 +433,11 @@ ;; charmacs.lisp #:syntax-char-code-limit #:search-char-code-limit #:do-alpha-chars + + ;; key-event.lisp + #:define-keysym-code #:define-mouse-keysym #:define-modifier-bit + #:*all-modifier-names* #:*modifier-translations* + #:make-key-event #:char-key-event #:do-alpha-key-events + #:key-event-modifier-mask #:key-event-char #:key-event-bit-p + #:pretty-key-string ;; display.lisp @@ -491,5 +454,5 @@ #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n - #:prompt-for-key-event #:prompt-for-key #:prompt-for-command-key + #:prompt-for-key-event #:prompt-for-key #:*logical-key-event-names* #:logical-key-event-p #:logical-key-event-documentation @@ -541,5 +504,5 @@ #:bind-key #:delete-key-binding #:get-command #:map-bindings #:make-command #:command-name #:command-bindings #:last-command-type - #:prefix-argument #:*invoke-hook* #:key-translation + #:prefix-argument #:key-translation @@ -586,7 +549,4 @@ (defpackage :hemlock (:use :common-lisp :hemlock-interface :hemlock-internals :hemlock-ext) - (:shadowing-import-from :hemlock-ext - #:char-code-limit) - #+clozure (:import-from :hemlock-ext #:log-debug) ) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp (revision 7993) @@ -137,5 +137,5 @@ (do-registers (name val :sorted) (write-string "Reg " f) - (hemlock-ext:print-pretty-key-event name f) + (write-string (pretty-key-string name) f) (write-string ": " f) (etypecase val Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp (revision 7993) @@ -48,5 +48,5 @@ is a function which is called with each object that falls off the end." - (unless (and (hemlock-ext:fixnump size) (> size 0)) + (unless (and (fixnump size) (> size 0)) (error "Ring size, ~S is not a positive fixnum." size)) (internal-make-ring :delete-function delete-function Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp (revision 7993) @@ -240,5 +240,5 @@ (round (- time (tq-event-last-time event)) internal-time-units-per-second))) - (hemlock-ext:without-interrupts + (without-interrupts (let ((interval (tq-event-interval event))) (when interval Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp (revision 7993) @@ -335,6 +335,4 @@ (defsetf last-command-type %set-last-command-type "Set the Last-Command-Type for use by the next command.") -(defsetf last-key-event-typed %set-last-key-event-typed - "Set the last key event typed") (defsetf logical-key-event-p %set-logical-key-event-p "Change what Logical-Char= returns for the specified arguments.") Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7992) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7993) @@ -40,9 +40,7 @@ (quote-next-p :initform nil :accessor hemlock-view-quote-next-p) (current-command :initform (make-array 10 :fill-pointer 0 :adjustable t) - :reader hemlock-current-command) - (current-translation :initform (make-array 10 :fill-pointer 0 :adjustable t) - :reader hemlock-current-translation) - (translate-key-temp :initform (make-array 10 :fill-pointer 0 :adjustable t) - :reader hemlock-translate-key-temp) + :accessor hemlock-current-command) + (last-command :initform (make-array 10 :fill-pointer 0 :adjustable t) + :accessor hemlock-last-command) (prefix-argument-state :initform (make-prefix-argument-state) :accessor hemlock-prefix-argument-state) @@ -53,5 +51,4 @@ ;; User level "view variables", for now give each its own slot. - (last-key-event-typed :initform nil :accessor hemlock-last-key-event-typed) (last-command-type :initform nil :accessor hemlock-last-command-type) (target-column :initform 0 :accessor hemlock-target-column) @@ -69,13 +66,14 @@ (defun last-key-event-typed () "This function returns the last key-event typed by the user and read as input." - (hemlock-last-key-event-typed (current-view))) - -(defun %set-last-key-event-typed (key) - (setf (hemlock-last-key-event-typed (current-view)) key)) + (let* ((view (current-view)) + (keys (hemlock-current-command view))) + (when (= (length keys) 0) ;; the normal case, when executing a command. + (setq keys (hemlock-last-command view))) + (when (> (length keys) 0) + (aref keys (1- (length keys)))))) (defun last-char-typed () - (let ((key (hemlock-last-key-event-typed (current-view)))) - (when key (hemlock-ext:key-event-char key)))) - + (let ((key (last-key-event-typed))) + (and key (key-event-char key)))) ;; This handles errors in event handling. It assumes it's called in a normal @@ -135,11 +133,13 @@ (abort)))) -(defmethod translate-and-lookup-current-command ((view hemlock-view)) +;; These are only used in event handling, and as such are serialized +(defparameter *translation-temp-1* (make-array 10 :fill-pointer 0 :adjustable t)) +(defparameter *translation-temp-2* (make-array 10 :fill-pointer 0 :adjustable t)) + +(defmethod translate-and-lookup-command (keys) ;; Returns NIL if we're in the middle of a command (either multi-key, as in c-x, ;; or translation prefix, as in ESC for Meta-), else a command. (multiple-value-bind (translated-key prefix-p) - (translate-key (hemlock-current-command view) - (hemlock-current-translation view) - (hemlock-translate-key-temp view)) + (translate-key keys *translation-temp-1* *translation-temp-2*) (multiple-value-bind (res t-bindings) (get-current-binding translated-key) @@ -153,46 +153,43 @@ nil (values (get-default-command) nil))))))) - + ;; This has a side effect of resetting the quoting state and current command. (defmethod get-command-binding-for-key ((view hemlock-view) key) - (vector-push-extend key (hemlock-current-command view)) - (setf (hemlock-last-key-event-typed view) key) - (multiple-value-bind (main-binding t-bindings) - (if (shiftf (hemlock-view-quote-next-p view) nil) - (values (get-self-insert-command) nil) - (let ((eps (hemlock-prompted-input-state view))) - (or (and eps (eps-parse-key-handler eps)) - (translate-and-lookup-current-command view)))) - (when main-binding - (setf (fill-pointer (hemlock-current-command view)) 0)) - (values main-binding t-bindings))) + (let ((current-keys (hemlock-current-command view))) + (vector-push-extend key current-keys) + (multiple-value-bind (main-binding t-bindings) + (if (shiftf (hemlock-view-quote-next-p view) nil) + (values (get-self-insert-command) nil) + (let ((eps (hemlock-prompted-input-state view))) + (or (and eps (eps-parse-key-handler eps)) + (translate-and-lookup-command current-keys)))) + (when main-binding + (let ((vec (hemlock-last-command view))) ;; reuse vector + (setf (hemlock-last-command view) current-keys) + (setf (fill-pointer vec) 0) + (setf (hemlock-current-command view) vec)) + (values main-binding t-bindings))))) (defvar *last-last-command-type*) (defvar *last-prefix-argument*) -;;; -(defvar *invoke-hook* #'(lambda (command p) (funcall (command-function command) p)) - "This function is called by the command interpreter when it wants to invoke a - command. The arguments are the command to invoke and the prefix argument. - The default value just calls the Command-Function with the prefix argument.") - +(defun invoke-command (command p) + (funcall (command-function command) p)) (defmethod execute-hemlock-key ((view hemlock-view) key) #+gz (log-debug "~&execute-hemlock-key ~s" key) - (if (or (symbolp key) (functionp key)) - (funcall key) - (with-output-to-listener - (multiple-value-bind (main-binding transparent-bindings) - (get-command-binding-for-key view key) - #+gz (log-debug "~& binding ~s ~s" main-binding transparent-bindings) - (when main-binding - (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil)) - (*last-prefix-argument* (hemlock::prefix-argument-resetting-state)) - ;(*echo-area-stream* (hemlock-echo-area-stream view)) - ) - (dolist (binding transparent-bindings) - (funcall *invoke-hook* binding *last-prefix-argument*)) - (funcall *invoke-hook* main-binding *last-prefix-argument*))))))) + (with-output-to-listener + (if (or (symbolp key) (functionp key)) + (funcall key) + (multiple-value-bind (main-binding transparent-bindings) + (get-command-binding-for-key view key) + #+gz (log-debug "~& binding ~s ~s" main-binding transparent-bindings) + (when main-binding + (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil)) + (*last-prefix-argument* (hemlock::prefix-argument-resetting-state))) + (dolist (binding transparent-bindings) + (invoke-command binding *last-prefix-argument*)) + (invoke-command main-binding *last-prefix-argument*))))))) (defmethod update-echo-area-after-command ((view hemlock-view)) @@ -208,8 +205,5 @@ (let ((cmd (hemlock-current-command view))) (unless (eql 0 (length cmd)) - (let ((cstr (with-output-to-string (s) - (loop for key across cmd - do (hemlock-ext:print-pretty-key key s) - do (write-char #\space s))))) + (let ((cstr (concatenate 'string (pretty-key-string cmd) " "))) (message cstr))))))))))