[climacs-cvs] CVS update: climacs/esa.lisp

[Robert Strandh]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv18396

Modified Files:
	esa.lisp 
Log Message:
Implemented `shallow command tables'. 

Made the ESA command loop search for key bindings in the inherit-from
list as well.  

Changed the ESA example so that com-quit is in the esa-global-table
and the example-global-table inherits from the esa-global-table. 

Next, it would be good to create many small command tables that
contain (say) all the commands that have to do with multi-windowing
(C-x 2, C-x 3, etc), all the commands that have to do with kbd macros,
all the commands that have to do with undo, etc.

Also, next, rearrange Climacs itself to take advantage of all this. 


Date: Fri Jul 22 09:05:44 2005
Author: rstrandh

Index: climacs/esa.lisp
diff -u climacs/esa.lisp:1.7 climacs/esa.lisp:1.8
--- climacs/esa.lisp:1.7	Fri Jul 22 07:36:58 2005
+++ climacs/esa.lisp	Fri Jul 22 09:05:44 2005
@@ -97,6 +97,13 @@
 	       (setf table (command-menu-item-value item)))
 	finally (return item)))
 
+(defun find-gestures-with-inheritance (gestures start-table)
+  (or (find-gestures gestures start-table)
+      (some (lambda (table)
+	      (find-gestures-with-inheritance gestures table))
+	    (command-table-inherit-from
+	     (find-command-table start-table)))))
+
 (defparameter *current-gesture* nil)
 
 (defun meta-digit (gesture)
@@ -185,7 +192,7 @@
 	 (setf *current-gesture* (esa-read-gesture))
 	 (setf gestures 
 	       (nconc gestures (list *current-gesture*)))
-	 (let ((item (find-gestures gestures command-table)))
+	 (let ((item (find-gestures-with-inheritance gestures command-table)))
 	   (cond 
 	     ((not item)
 	      (beep) (return))
@@ -252,7 +259,7 @@
        (redisplay-frame-panes *application-frame*)
        (loop while ,loop-condition
              as ,gesture = (esa-read-gesture)
-             as ,item = (find-gestures (list ,gesture) ,command-table)
+             as ,item = (find-gestures-with-inheritance (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)))
@@ -294,7 +301,18 @@
 	       (ensure-subtable table (car gestures))
 	       (cdr gestures))))
   
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; standard key bindings 
 
+;;; global
+
+(define-command-table global-esa-table)
+
+(define-command (com-quit :name t :command-table global-esa-table) ()
+  (frame-exit *application-frame*))
+
+(set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
@@ -360,9 +378,5 @@
 ;;; 
 ;;; Commands and key bindings
 
-(define-command-table global-example-table)
-
-(define-command (com-quit :name t :command-table global-example-table) ()
-  (frame-exit *application-frame*))
+(define-command-table global-example-table :inherit-from (global-esa-table))
 
-(set-key 'com-quit 'global-example-table '((#\x :control) (#\c :control)))