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