Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv10689
Modified Files:
esa.lisp gui.lisp packages.lisp
Log Message:
Migration of initial common functionality from gui.lisp to esa.lisp
completed. Next to migrate should be keyboard macros, pane splitting,
and other functionality not specific to Climacs.
Date: Thu Jul 21 14:24:31 2005
Author: rstrandh
Index: climacs/esa.lisp
diff -u climacs/esa.lisp:1.4 climacs/esa.lisp:1.5
--- climacs/esa.lisp:1.4 Thu Jul 21 07:13:51 2005
+++ climacs/esa.lisp Thu Jul 21 14:24:30 2005
@@ -27,7 +27,7 @@
;;; Info pane, a pane that displays some information about another pane
(defclass info-pane (application-pane)
- ((master-pane :initarg :master-pane))
+ ((master-pane :initarg :master-pane :reader master-pane))
(:default-initargs
:background +gray85+
:scroll-bars nil
@@ -79,7 +79,9 @@
(recordingp :initform nil :accessor recordingp)
(executingp :initform nil :accessor executingp)
(recorded-keys :initform '() :accessor recorded-keys)
- (remaining-keys :initform '() :accessor remaining-keys)))
+ (remaining-keys :initform '() :accessor remaining-keys)
+ ;; temporary hack. The command table should be buffer or pane specific
+ (command-table :initarg :command-table :reader command-table)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -222,7 +224,6 @@
partial-command-parser prompt)
(declare (ignore command-parser command-unparser partial-command-parser prompt))
(with-slots (windows) frame
- (setf windows (list (find-real-pane (find-pane-named frame 'win))))
(let ((*standard-output* (car windows))
(*standard-input* (frame-standard-input frame))
(*print-pretty* nil)
@@ -234,9 +235,9 @@
(progn
(handler-case
(with-input-context
- ('(command :command-table global-example-table))
+ (`(command :command-table ,(command-table frame)))
(object)
- (process-gestures frame 'global-example-table)
+ (process-gestures frame (command-table frame))
(t
(execute-frame-command frame object)
(setq maybe-error nil)))
@@ -246,6 +247,27 @@
(redisplay-frame-panes frame))
(return-to-climacs () nil))))))
+(defmacro simple-command-loop (command-table loop-condition end-clauses)
+ (let ((gesture (gensym))
+ (item (gensym))
+ (command (gensym)))
+ `(progn
+ (redisplay-frame-panes *application-frame*)
+ (loop while ,loop-condition
+ as ,gesture = (esa-read-gesture)
+ as ,item = (find-gestures (list ,gesture) ,command-table)
+ do (cond ((and ,item (eq (command-menu-item-type ,item) :command))
+ (setf *current-gesture* ,gesture)
+ (let ((,command (command-menu-item-value ,item)))
+ (unless (consp ,command)
+ (setf ,command (list ,command)))
+ (execute-frame-command *application-frame*
+ ,command)))
+ (t
+ (unread-gesture ,gesture)
+ ,@end-clauses))
+ (redisplay-frame-panes *application-frame*)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; example application
@@ -259,8 +281,7 @@
(defun display-info (frame pane)
(declare (ignore frame))
- (with-slots (master-pane) pane
- (format pane "Pane name: ~s" (pane-name master-pane))))
+ (format pane "Pane name: ~s" (pane-name (master-pane pane))))
(defclass example-minibuffer-pane (minibuffer-pane)
()
@@ -283,6 +304,7 @@
(make-pane 'example-info-pane
:master-pane my-pane
:width 900)))
+ (setf (windows *application-frame*) (list my-pane))
(vertically ()
(scrolling ()
my-pane)
@@ -301,7 +323,10 @@
(defun example (&key (width 900) (height 400))
"Starts up the example application"
- (let ((frame (make-application-frame 'example :width width :height height)))
+ (let ((frame (make-application-frame
+ 'example
+ :width width :height height
+ :command-table 'global-example-table)))
(run-frame-top-level frame)))
(define-command-table global-example-table)
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.160 climacs/gui.lisp:1.161
--- climacs/gui.lisp:1.160 Thu Jul 21 07:13:51 2005
+++ climacs/gui.lisp Thu Jul 21 14:24:30 2005
@@ -37,14 +37,6 @@
(dabbrev-expansion-mark :initform nil)
(overwrite-mode :initform nil)))
-;;; a pane that displays some information about another pane
-(defclass info-pane (application-pane)
- ((master-pane :initarg :master-pane))
- (:default-initargs
- :background +gray85+
- :scroll-bars nil
- :borders nil))
-
(defclass climacs-info-pane (info-pane)
()
(:default-initargs
@@ -57,18 +49,9 @@
(:default-initargs
:height 20 :max-height 20 :min-height 20))
-;;; eventually remove in favor of esa-frame-mixin
-(defclass multi-frame-mixin ()
- ((windows :accessor windows)
- (buffers :initform '() :accessor buffers)
- (recordingp :initform nil :accessor recordingp)
- (executingp :initform nil :accessor executingp)
- (recorded-keys :initform '() :accessor recorded-keys)
- (remaining-keys :initform '() :accessor remaining-keys)))
-
(define-application-frame climacs (standard-application-frame
- multi-frame-mixin)
- ()
+ esa-frame-mixin)
+ ((buffers :initform '() :accessor buffers))
(:panes
(win (let* ((extended-pane
(make-pane 'extended-pane
@@ -81,6 +64,7 @@
(make-pane 'climacs-info-pane
:master-pane extended-pane
:width 900)))
+ (setf (windows *application-frame*) (list extended-pane))
(vertically ()
(scrolling ()
extended-pane)
@@ -91,7 +75,7 @@
(vertically (:scroll-bars nil)
win
int)))
- (:top-level (climacs-top-level)))
+ (:top-level (esa-top-level)))
(defun current-window ()
(car (windows *application-frame*)))
@@ -107,30 +91,32 @@
(defun climacs (&key (width 900) (height 400))
"Starts up a climacs session"
- (let ((frame (make-application-frame 'climacs :width width :height height)))
+ (let ((frame (make-application-frame
+ 'climacs :width width :height height
+ :command-table 'global-climacs-table)))
(run-frame-top-level frame)))
(defun display-info (frame pane)
(declare (ignore frame))
- (with-slots (master-pane) pane
- (let* ((buf (buffer master-pane))
- (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a"
- (if (needs-saving buf) "**" "--")
- (name buf)
- (name (syntax buf))
- (if (slot-value master-pane 'overwrite-mode)
- " Ovwrt"
- "")
- (if (auto-fill-mode master-pane)
- " Fill"
- "")
- (if (isearch-mode master-pane)
- " Isearch"
- "")
- (if (recordingp *application-frame*)
- "Def"
- ""))))
- (princ name-info pane))))
+ (let* ((master-pane (master-pane pane))
+ (buf (buffer master-pane))
+ (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a"
+ (if (needs-saving buf) "**" "--")
+ (name buf)
+ (name (syntax buf))
+ (if (slot-value master-pane 'overwrite-mode)
+ " Ovwrt"
+ "")
+ (if (auto-fill-mode master-pane)
+ " Fill"
+ "")
+ (if (isearch-mode master-pane)
+ " Isearch"
+ "")
+ (if (recordingp *application-frame*)
+ "Def"
+ ""))))
+ (princ name-info pane)))
(defun display-win (frame pane)
"The display function used by the climacs application frame."
@@ -141,18 +127,7 @@
(declare (ignore region))
(redisplay-frame-pane *application-frame* pane))
-(defun find-gestures (gestures start-table)
- (loop with table = (find-command-table start-table)
- for (gesture . rest) on gestures
- for item = (find-keystroke-item gesture table :errorp nil)
- while item
- do (if (eq (command-menu-item-type item) :command)
- (return (if (null rest) item nil))
- (setf table (command-menu-item-value item)))
- finally (return item)))
-
(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
-(defparameter *current-gesture* nil)
(defun meta-digit (gesture)
(position gesture
@@ -160,68 +135,6 @@
(#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
:test #'event-matches-gesture-name-p))
-(defun generic-read-gesture ()
- (unless (null (remaining-keys *application-frame*))
- (return-from generic-read-gesture
- (pop (remaining-keys *application-frame*))))
- (loop for gesture = (read-gesture :stream *standard-input*)
- until (or (characterp gesture)
- (and (typep gesture 'keyboard-event)
- (or (keyboard-event-character gesture)
- (not (member (keyboard-event-key-name
- gesture)
- '(:control-left :control-right
- :shift-left :shift-right
- :meta-left :meta-right
- :super-left :super-right
- :hyper-left :hyper-right
- :shift-lock :caps-lock
- :alt-left :alt-right))))))
- finally (progn (when (recordingp *application-frame*)
- (push gesture (recorded-keys *application-frame*)))
- (return gesture))))
-
-(defun generic-unread-gesture (gesture stream)
- (cond ((recordingp *application-frame*)
- (pop (recorded-keys *application-frame*))
- (unread-gesture gesture :stream stream))
- ((executingp *application-frame*)
- (push gesture (remaining-keys *application-frame*)))
- (t
- (unread-gesture gesture :stream stream))))
-
-(defun read-numeric-argument (&key (stream *standard-input*))
- (let ((gesture (generic-read-gesture)))
- (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
- (let ((numarg 4))
- (loop for gesture = (generic-read-gesture)
- while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
- do (setf numarg (* 4 numarg))
- finally (generic-unread-gesture gesture stream))
- (let ((gesture (generic-read-gesture)))
- (cond ((and (characterp gesture)
- (digit-char-p gesture 10))
- (setf numarg (- (char-code gesture) (char-code #\0)))
- (loop for gesture = (generic-read-gesture)
- while (and (characterp gesture)
- (digit-char-p gesture 10))
- do (setf numarg (+ (* 10 numarg)
- (- (char-code gesture) (char-code #\0))))
- finally (generic-unread-gesture gesture stream)
- (return (values numarg t))))
- (t
- (generic-unread-gesture gesture stream)
- (values numarg t))))))
- ((meta-digit gesture)
- (let ((numarg (meta-digit gesture)))
- (loop for gesture = (generic-read-gesture)
- while (meta-digit gesture)
- do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
- finally (generic-unread-gesture gesture stream)
- (return (values numarg t)))))
- (t (generic-unread-gesture gesture stream)
- (values 1 nil)))))
-
;;; we know the vbox pane has a scroller pane and an info
;;; pane in it. The scroller pane has a viewport in it,
;;; and the viewport contains the climacs-pane as its only child.
@@ -232,8 +145,6 @@
(find-if (lambda (pane) (typep pane 'scroller-pane))
(sheet-children vbox)))))))
-(defvar *numeric-argument-p* (list nil))
-
(defun substitute-numeric-argument-p (command numargp)
(substitute numargp *numeric-argument-p* command :test #'eq))
@@ -258,102 +169,6 @@
(loop for buffer in (buffers frame)
do (when (modified-p buffer)
(setf (needs-saving buffer) t))))
-
-(defmethod execute-frame-command :after ((frame multi-frame-mixin) command)
- (setf (previous-command *standard-output*)
- (if (consp command)
- (car command)
- command)))
-
-(defmethod redisplay-frame-panes :around ((frame multi-frame-mixin) &key force-p)
- (declare (ignore force-p))
- (when (null (remaining-keys *application-frame*))
- (setf (executingp *application-frame*) nil)
- (call-next-method)))
-
-(defun process-gestures (frame command-table)
- (loop
- for gestures = '()
- do (multiple-value-bind (numarg numargp)
- (read-numeric-argument :stream *standard-input*)
- (loop
- (setf *current-gesture* (generic-read-gesture))
- (setf gestures
- (nconc gestures (list *current-gesture*)))
- (let ((item (find-gestures gestures command-table)))
- (cond
- ((not item)
- (beep) (return))
- ((eq (command-menu-item-type item) :command)
- (let ((command (command-menu-item-value item)))
- (unless (consp command)
- (setf command (list command)))
- (setf command (substitute-numeric-argument-marker command numarg))
- (setf command (substitute-numeric-argument-p command numargp))
- (execute-frame-command frame command)
- (return)))
- (t nil)))))
- do (redisplay-frame-panes frame)))
-
-(defun climacs-top-level (frame &key
- command-parser command-unparser
- partial-command-parser prompt)
- (declare (ignore command-parser command-unparser partial-command-parser prompt))
- (with-slots (windows) frame
- (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
- (push (buffer (car windows)) (buffers frame))
- (let ((*standard-output* (car windows))
- (*standard-input* (frame-standard-input frame))
- (*print-pretty* nil)
- (*abort-gestures* '((:keyboard #\g 512))))
- (redisplay-frame-panes frame :force-p t)
- (loop
- for maybe-error = t
- do (restart-case
- (progn
- (handler-case
- (with-input-context
- ('(command :command-table global-climacs-table))
- (object)
- (process-gestures frame 'global-climacs-table)
- (t
- (execute-frame-command frame object)
- (setq maybe-error nil)))
- (abort-gesture () (display-message "Quit")))
- (when maybe-error
- (beep))
- (redisplay-frame-panes frame))
- (return-to-climacs () nil))))))
-
-(defmacro simple-command-loop (command-table loop-condition end-clauses)
- (let ((gesture (gensym))
- (item (gensym))
- (command (gensym)))
- `(progn
- (redisplay-frame-panes *application-frame*)
- (loop while ,loop-condition
- as ,gesture = (generic-read-gesture)
- as ,item = (find-gestures (list ,gesture) ,command-table)
- do (cond ((and ,item (eq (command-menu-item-type ,item) :command))
- (setf *current-gesture* ,gesture)
- (let ((,command (command-menu-item-value ,item)))
- (unless (consp ,command)
- (setf ,command (list ,command)))
- (handler-case
- (execute-frame-command *application-frame*
- ,command)
- (offset-before-beginning ()
- (beep) (display-message "Beginning of buffer"))
- (offset-after-end ()
- (beep) (display-message "End of buffer"))
- (motion-before-beginning ()
- (beep) (display-message "Beginning of buffer"))
- (motion-after-end ()
- (beep) (display-message "End of buffer")))))
- (t
- (unread-gesture ,gesture)
- ,@end-clauses))
- (redisplay-frame-panes *application-frame*)))))
(defmacro define-named-command (command-name args &body body)
`(define-climacs-command ,(if (listp command-name)
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.66 climacs/packages.lisp:1.67
--- climacs/packages.lisp:1.66 Thu Jul 21 07:13:51 2005
+++ climacs/packages.lisp Thu Jul 21 14:24:30 2005
@@ -170,9 +170,12 @@
(:use :clim-lisp :clim)
(:export #:minibuffer-pane #:display-message
#:esa-pane-mixin #:previous-command
-;; #:esa-frame-mixin #:windows #:recordingp #:execcutingp
-;; #:*numeric-argument-p*
- #:esa-top-level))
+ #:info-pane #:master-pane
+ #:esa-frame-mixin #:windows #:recordingp #:executingp
+ #:*numeric-argument-p* #:*current-gesture*
+ #:esa-top-level #:simple-command-loop
+ ;; remove these when kbd macros move to esa
+ #:recorded-keys #:remaining-keys))
(defpackage :climacs-gui
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
