From e1557ec8bb6e6026ed3d567205ed63bd5071b1e8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jacek=20TeMPOraL=20Z=C5=82ydach?= <temporal.pl@gmail.com>
Date: Sun, 14 May 2017 19:16:50 +0200
Subject: [PATCH] A bunch of temporary workarounds around broken / missing
 features.

---
 clim/db-menu.lisp       |   6 +-
 clim/db-stream.lisp     |   6 +-
 clim/frames.lisp        | 141 ++++++++++++++++++++--------------------
 clim/window-stream.lisp |   7 +-
 4 files changed, 86 insertions(+), 74 deletions(-)

diff --git a/clim/db-menu.lisp b/clim/db-menu.lisp
index d627dc0f..aef0faa9 100644
--- a/clim/db-menu.lisp
+++ b/clim/db-menu.lisp
@@ -285,8 +285,10 @@
 				      (make-pane 'menu-bar-button-logic
 						 :label name
 						 :next-menu value)
-				    (error "not yet implemented")
-				    )))
+                                      (make-pane 'push-button
+                                                 :label name)
+                                      ;(error "not yet implemented")
+                                      )))
 			    (make-command-table-menu command-table))))
 	       (make-pane 'hbox-pane :contents buttons 
 			  :min-height 2 :height 2))))
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 1b5fd912..0b454275 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -453,8 +453,10 @@
                                           :name name
                                           :thickness 1
                                           :contents pane
-                                          :background background)
-                     :background background)))
+                                          ;; :background background
+                                          )
+                     ;; :background background -- NOTE this actually should work!
+                     )))
       (values pane stream))))
 
 (defmacro make-clim-interactor-pane (&rest options)
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 5942f109..28e6d6d8 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -907,69 +907,69 @@
 
 (defmethod default-frame-top-level ((frame standard-application-frame)
                                     &key command-parser command-unparser
-                                         partial-command-parser
-                                         (prompt "Command: "))
+                                      partial-command-parser
+                                      (prompt "Command: "))
   (unless (eq (frame-state frame) :enabled)
     (enable-frame frame))
   (loop
-    (let* ((*standard-output*
-	    (or (frame-standard-output frame) *standard-output*))
-	   (*standard-input*
-	    (or (frame-standard-input frame) *standard-input*))
-	   (*query-io*
-	    (or (frame-query-io frame) *query-io*))
-	   (*error-output*
-	    (or (frame-error-output frame) *error-output*))
-	   (*pointer-documentation-output*
-	    (frame-pointer-documentation-output frame))
-	   (interactor
-	    (not (null (find-frame-pane-of-type frame 'interactor-pane))))
-	   (*command-parser*
-	    (or command-parser
-		(if interactor
-		    #'command-line-command-parser
-		  #'menu-command-parser)))
-	   (*command-unparser*
-	    (or command-unparser
-		#'command-line-command-unparser))
-	   (*partial-command-parser*
-	    (or partial-command-parser
-		(if interactor
-		    #'command-line-read-remaining-arguments-for-partial-command
-		  #'menu-read-remaining-arguments-for-partial-command)))
-	   (command-stream
-	    ;;--- We have to ask the frame since we do not want to
-	    ;;--- just pick up a stream from the dynamic environment
-	    (let ((si (or (frame-standard-input frame)
-			  (frame-standard-output frame))))
-	      (typecase si
-		(output-protocol-mixin si)
-		(t (frame-top-level-sheet frame)))))
-	   (*avv-refreshed* nil))
-      ;; The read-eval-print loop for applications...
-      (letf-globally (((frame-actual-pointer-documentation-pane frame)
-		       *pointer-documentation-output*))
-	(loop
-	  ;; Redisplay all the panes
-	  (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
-	    (redisplay-frame-panes frame)
-	    (when (not *avv-refreshed*) 
-	      ;;; This needs to happen after the 
-	      ;;; call to redisplay-frame-panes
-	      ;;; but only do it the first time.
-	      (force-refresh-avv-streams frame)
-	      (setq *avv-refreshed* t))
-	    (when interactor
-	      (fresh-line *standard-input*)
-	      (if (stringp prompt)
-		  (write-string prompt *standard-input*)
-		(funcall prompt *standard-input* frame)))
-	    (let ((command (read-frame-command frame :stream command-stream)))
-	      (when interactor
-		(terpri *standard-input*))
-	      ;; Need this check in case the user aborted out of a command menu
-	      (when command
-		(execute-frame-command frame command)))))))))
+     (let* ((*standard-output*
+             (or (frame-standard-output frame) *standard-output*))
+            (*standard-input*
+             (or (frame-standard-input frame) *standard-input*))
+            (*query-io*
+             (or (frame-query-io frame) *query-io*))
+            (*error-output*
+             (or (frame-error-output frame) *error-output*))
+            (*pointer-documentation-output*
+             (frame-pointer-documentation-output frame))
+            (interactor
+             (not (null (find-frame-pane-of-type frame 'interactor-pane))))
+            (*command-parser*
+             (or command-parser
+                 (if interactor
+                     #'command-line-command-parser
+                     #'menu-command-parser)))
+            (*command-unparser*
+             (or command-unparser
+                 #'command-line-command-unparser))
+            (*partial-command-parser*
+             (or partial-command-parser
+                 (if interactor
+                     #'command-line-read-remaining-arguments-for-partial-command
+                     #'menu-read-remaining-arguments-for-partial-command)))
+            (command-stream
+             ;;--- We have to ask the frame since we do not want to
+             ;;--- just pick up a stream from the dynamic environment
+             (let ((si (or (frame-standard-input frame)
+                           (frame-standard-output frame))))
+               (typecase si
+                 (output-protocol-mixin si)
+                 (t (frame-top-level-sheet frame)))))
+            (*avv-refreshed* nil))
+       ;; The read-eval-print loop for applications...
+       (letf-globally (((frame-actual-pointer-documentation-pane frame)
+                        *pointer-documentation-output*))
+         (loop
+            ;; Redisplay all the panes
+            (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
+              (redisplay-frame-panes frame)
+              (when (not *avv-refreshed*) 
+;;; This needs to happen after the 
+;;; call to redisplay-frame-panes
+;;; but only do it the first time.
+                (force-refresh-avv-streams frame)
+                (setq *avv-refreshed* t))
+              (when interactor
+                (fresh-line *standard-input*)
+                (if (stringp prompt)
+                    (write-string prompt *standard-input*)
+                    (funcall prompt *standard-input* frame)))
+              (let ((command (read-frame-command frame :stream command-stream)))
+                (when interactor
+                  (terpri *standard-input*))
+                ;; Need this check in case the user aborted out of a command menu
+                (when command
+                  (execute-frame-command frame command)))))))))
 
 (defmethod force-refresh-avv-streams (frame)
   ;;; NOTE:  Not using get-frame-pane-to-avv-stream-table.
@@ -1278,7 +1278,8 @@
      (re-enable-menu-items ,frame)))
 
 (defmethod execute-frame-command ((frame standard-application-frame) command)
-  (apply (command-name command) (command-arguments command))
+  (when (listp command)                 ;NOTE workaround for command == :timeout
+    (apply (command-name command) (command-arguments command)))
   #+ignore ;; from jeff on 4/8/99
   (with-menu-disabled frame
     (apply (command-name command) (command-arguments command))))
@@ -1488,14 +1489,16 @@
       button-press-event)))
 
 (defun find-frame-pane-of-type (frame type)
-  (map-over-sheets #'(lambda (sheet)
-                       (when (typep sheet type)
-                         (return-from find-frame-pane-of-type sheet)))
-                   (frame-top-level-sheet frame)))
+  (prog1 (map-over-sheets #'(lambda (sheet)
+                        (when (typep sheet type)
+                          (return-from find-frame-pane-of-type sheet)))
+                          (frame-top-level-sheet frame))))
 
 (defmethod frame-standard-output ((frame standard-application-frame))
-  (if (not (member '*standard-output* (slot-value frame 
-						  'non-frame-stream-names)))
+  *standard-output*
+  ;; commented out because it causes frame-not-a-stream error
+  #+nil(if (not (member '*standard-output* (slot-value frame 
+                                                  'non-frame-stream-names)))
       (or 
        (find-frame-pane-of-type frame 'application-pane)
        (find-frame-pane-of-type frame 'interactor-pane))
@@ -1503,9 +1506,9 @@
 
 (defmethod frame-standard-input ((frame standard-application-frame))
   (if (not (member '*standard-input* (slot-value frame 
-						  'non-frame-stream-names)))
+                                                 'non-frame-stream-names)))
       (or (find-frame-pane-of-type frame 'interactor-pane)
-	  (frame-standard-output frame))))
+          (frame-standard-output frame))))
   
 (defmethod frame-query-io ((frame standard-application-frame))
   (if (not (member '*query-io* (slot-value frame 
diff --git a/clim/window-stream.lisp b/clim/window-stream.lisp
index 219ec619..f4b47035 100644
--- a/clim/window-stream.lisp
+++ b/clim/window-stream.lisp
@@ -32,7 +32,7 @@
   nil)
 
 
-#-silica        ;--- no such slots in Silica
+#- (or silica sbcl ccl)                             ;--- no such slots in Silica
 (defmethod print-object ((window window-stream) stream)
   (print-unreadable-object (window stream :type t :identity t)
     (let ((left (safe-slot-value window 'left))
@@ -41,6 +41,11 @@
           (bottom (safe-slot-value window 'bottom)))
       (format stream "/x ~D:~D y ~D:~D/" left right top bottom))))
 
+#+ (or silica sbcl ccl)
+(defmethod print-object ((window window-stream) stream)
+  (print-unreadable-object (window stream :type t :identity t)
+    (format stream "a window stream")))
+
 (defmethod window-stream-class-name ((window-stream window-stream))
   (class-name (class-of window-stream)))
 
-- 
GitLab