Browse code

fix a DOLIST bug found on clisp

D Herring authored on 2012-05-13 13:08:17
Showing 1 changed files
... ...
@@ -505,12 +505,15 @@
505 505
     (ltk:bind edit-ctrl "<Map>" (lambda (evt) (declare (ignore evt)) (ltk:focus edit-ctrl)))
506 506
     (ltk:bind edit-ctrl "<<Modified>>" (lambda (evt) (on-file-modified evt)))
507 507
     (dolist (binding *text-keys*)
508
-      ;;(format t "~%binding ~A to ~A" (first binding) (second binding))
509
-      (add-key-binding edit-ctrl (first binding)
510
-                       (lambda (evt)
511
-                         (declare (ignore evt))
512
-                         ;;(format t "~%calling ~A" (second binding))
513
-                         (funcall (second binding) edit-ctrl))))
508
+      ;; dolist may re-use the binding... force unique bindings (test in clisp)
509
+      (destructuring-bind (key action &optional suppress-in-repl) binding
510
+        (declare (ignore suppress-in-repl))
511
+        ;;(format t "~%binding ~A to ~A" key action)
512
+        (add-key-binding edit-ctrl key
513
+          (lambda (evt)
514
+            (declare (ignore evt))
515
+            ;;(format t "~%calling ~A" action)
516
+            (funcall action edit-ctrl)))))
514 517
     (ltk:bind edit-ctrl "<Return>"
515 518
       (lambda (evt) (unless (plaintextp txt) (on-return-key edit-ctrl evt))))
516 519
     (ltk:bind edit-ctrl "<space>"
... ...
@@ -656,17 +659,18 @@
656 659
     (ltk:bind text "<BackSpace>" (lambda (evt) (declare (ignore evt)) (repl-delete-key-down listener)) :exclusive t)
657 660
     (ltk:bind text "<Escape>" (lambda (evt) (declare (ignore evt)) (clear listener)) :exclusive t)
658 661
     (dolist (binding *text-keys*)
659
-      (unless (third binding)
660
-        ;;(format t "~%repl: binding ~A to ~A" (first binding) (second binding))
661
-        (add-key-binding text (first binding)
662
-                         (lambda (evt)
663
-                           (declare (ignore evt))
664
-                           ;;(format t "~%calling ~A" (second binding))
665
-                           (funcall (second binding) text)))))
662
+      (destructuring-bind (key action &optional suppress-in-repl) binding
663
+        (unless suppress-in-repl
664
+          ;;(format t "~%repl: binding ~A to ~A" key action)
665
+          (add-key-binding text key
666
+            (lambda (evt)
667
+              (declare (ignore evt))
668
+              ;;(format t "~%calling ~A" action)
669
+              (funcall action text))))))
666 670
     (add-key-binding text *key-code-complete*
667
-                     (lambda (evt)
668
-                       (declare (ignore evt))
669
-                       (on-code-complete listener)))
671
+      (lambda (evt)
672
+        (declare (ignore evt))
673
+        (on-code-complete listener)))
670 674
     (ltk:bind text "<Escape>" (lambda (evt) (declare (ignore evt)) (clear listener)) :exclusive t)
671 675
     (ltk:bind text "<Key-bracketleft>"
672 676
       (lambda (evt) (on-left-bracket-key text evt)) :exclusive t)
... ...
@@ -988,7 +992,8 @@
988 992
 
989 993
 (defun bind-commands ()
990 994
   (dolist (entry *keytable*)
991
-    (add-key-binding ltk::*tk* (first entry) (second entry))))
995
+    (destructuring-bind (key action) entry
996
+      (add-key-binding ltk::*tk* key action))))
992 997
 
993 998
 (defun create-menus ()
994 999
   (let* ((mb (ltk:make-menubar))