diff options
| -rw-r--r-- | Backends/CLX-fb/frame-manager.lisp | 35 | ||||
| -rw-r--r-- | Backends/CLX-fb/mcclim-clx-fb.asd | 1 | ||||
| -rw-r--r-- | Backends/CLX-fb/port.lisp | 9 | ||||
| -rw-r--r-- | Backends/CLX/basic.lisp | 73 | ||||
| -rw-r--r-- | Backends/CLX/port.lisp | 8 | ||||
| -rw-r--r-- | Extensions/fonts/mcclim-native-ttf.lisp | 2 |
6 files changed, 38 insertions, 90 deletions
diff --git a/Backends/CLX-fb/frame-manager.lisp b/Backends/CLX-fb/frame-manager.lisp deleted file mode 100644 index 122cbad6..00000000 --- a/Backends/CLX-fb/frame-manager.lisp +++ /dev/null @@ -1,35 +0,0 @@ -;;; --------------------------------------------------------------------------- -;;; License: LGPL-2.1+ (See file 'Copyright' for details). -;;; --------------------------------------------------------------------------- -;;; -;;; (c) copyright 2016 Alessandro Serra <gas2serra@gmail.com> -;;; (c) copyright 2018-2020 Daniel Kochmański <daniel@turtleware.eu> -;;; -;;; --------------------------------------------------------------------------- -;;; -;;; The frame manager the CLX framebuffer backend. -;;; - -(in-package #:clim-clx-fb) - -(defclass clx-fb-frame-manager (clim-clx::clx-frame-manager) - () - (:default-initargs :mirroring :single - :class-gensym (gensym "CLXFB"))) - -(defmethod find-concrete-pane-class ((fm clx-fb-frame-manager) - pane-type &optional (errorp t)) - ;; This backend doesn't have any specialized pane implementations - ;; but depending on circumstances it may add optional mirroring to - ;; the class. Such automatically defined concrete class has the same - ;; name but with a gensym prefix and symbol in the backend package. - (let ((concrete-pane-class (find-concrete-pane-class t pane-type errorp))) - (maybe-add-mirroring-superclasses - concrete-pane-class (mirroring fm) - (symbol-name (class-gensym fm)) (find-package '#:clim-clx-fb) - (lambda (concrete-pane-class) - `(,(find-class 'mirrored-sheet-mixin) - ,@(unless (subtypep concrete-pane-class 'sheet-with-medium-mixin) - `(;; temporary-medium-sheet-output-mixin - ,(find-class 'permanent-medium-sheet-output-mixin))) - ,concrete-pane-class))))) diff --git a/Backends/CLX-fb/mcclim-clx-fb.asd b/Backends/CLX-fb/mcclim-clx-fb.asd index 56308cc6..6f289806 100644 --- a/Backends/CLX-fb/mcclim-clx-fb.asd +++ b/Backends/CLX-fb/mcclim-clx-fb.asd @@ -5,6 +5,5 @@ :components ((:file "package") (:file "port" :depends-on ("package" "medium")) - (:file "frame-manager" :depends-on ("port" "package")) (:file "medium" :depends-on ("package")) (:file "mirror" :depends-on ("port" "package")))) diff --git a/Backends/CLX-fb/port.lisp b/Backends/CLX-fb/port.lisp index f84f1ccd..a21278a0 100644 --- a/Backends/CLX-fb/port.lisp +++ b/Backends/CLX-fb/port.lisp @@ -8,15 +8,6 @@ (defmethod find-port-type ((type (eql :clx-fb))) (values 'clx-fb-port (nth-value 1 (find-port-type :clx)))) -(defmethod initialize-instance :after ((port clx-fb-port) &rest args) - (declare (ignore args)) - (push (make-instance 'clx-fb-frame-manager :port port) - (slot-value port 'frame-managers)) - (setf (slot-value port 'pointer) - (make-instance 'clim-clx::clx-basic-pointer :port port)) - (initialize-clx port) - (clim-extensions:port-all-font-families port)) - (defmethod realize-mirror ((port clx-fb-port) (sheet mirrored-sheet-mixin)) (let* ((window (clim-clx::%realize-mirror port sheet)) (mirror (make-instance 'clx-fb-mirror :mirror window))) diff --git a/Backends/CLX/basic.lisp b/Backends/CLX/basic.lisp index 4687fea9..8107d53b 100644 --- a/Backends/CLX/basic.lisp +++ b/Backends/CLX/basic.lisp @@ -25,6 +25,42 @@ (cursor-table :initform (make-hash-table :test #'eq) :accessor clx-port-cursor-table))) +(defun clx-io-loop (port) + (loop (with-simple-restart + (restart-event-loop "Restart CLIM's event loop.") + (loop (process-next-event port)) ))) + +(defmethod initialize-instance :after ((port clx-basic-port) &rest args) + (declare (ignore args)) + (let ((options (cdr (port-server-path port)))) + (setf (clx-port-display port) + (xlib:open-display (getf options :host) + :display (getf options :display-id) + :protocol (getf options :protocol))) + (setf (xlib:display-error-handler (clx-port-display port)) + #'clx-error-handler) + ;; Uncomment this when debugging CLX backend if asynchronous errors become + ;; troublesome. + #+ (or) + (setf (xlib:display-after-function (clx-port-display port)) + #'xlib:display-finish-output) + (setf (clx-port-screen port) + (nth (getf options :screen-id) + (xlib:display-roots (clx-port-display port)))) + (setf (clx-port-window port) (xlib:screen-root (clx-port-screen port))) + (make-cursor-table port) + (make-graft port) + (setf (slot-value port 'pointer) + (make-instance 'clim-clx::clx-basic-pointer :port port)) + (push (apply #'make-instance 'clx-frame-manager :port port options) + (slot-value port 'frame-managers)) + (clime:port-all-font-families port) + (when clim-sys:*multiprocessing-p* + (setf (port-event-process port) + (clim-sys:make-process + (climi::curry #'clx-io-loop port) + :name (format nil "~S's I/O process." port)))))) + (defclass clx-basic-pointer (standard-pointer) () (:default-initargs :cursor :upper-left)) @@ -41,45 +77,10 @@ (eq error-name 'xlib:match-error))) (apply #'xlib:default-error-handler display error-name args))) -(defgeneric initialize-clx (port)) - -(defmethod initialize-clx ((port clx-basic-port)) - (let ((options (cdr (port-server-path port)))) - (setf (clx-port-display port) - (xlib:open-display (getf options :host) - :display (getf options :display-id) - :protocol (getf options :protocol))) - (progn - (setf (xlib:display-error-handler (clx-port-display port)) - #'clx-error-handler) - ;; Uncomment this when debugging CLX backend if asynchronous - ;; errors become troublesome. - #+nil - (setf (xlib:display-after-function (clx-port-display port)) - #'xlib:display-finish-output)) - (setf (clx-port-screen port) - (nth (getf options :screen-id) - (xlib:display-roots (clx-port-display port)))) - (setf (clx-port-window port) (xlib:screen-root (clx-port-screen port))) - (make-cursor-table port) - (make-graft port) - (when clim-sys:*multiprocessing-p* - (setf (port-event-process port) - (clim-sys:make-process - (lambda () - (loop - (with-simple-restart - (restart-event-loop - "Restart CLIM's event loop.") - (loop - (process-next-event port)) ))) - :name (format nil "~S's event process." port)))))) - (defmethod destroy-port :before ((port clx-basic-port)) (when-let ((display (clx-port-display port))) (setf (clx-port-display port) nil) - (handler-case - (xlib:close-display display) + (handler-case (xlib:close-display display) (stream-error () (xlib:close-display display :abort t))))) diff --git a/Backends/CLX/port.lisp b/Backends/CLX/port.lisp index a7af388a..d523e095 100644 --- a/Backends/CLX/port.lisp +++ b/Backends/CLX/port.lisp @@ -87,14 +87,6 @@ (defmethod find-port-type ((type (eql :clx))) (values 'clx-port 'parse-clx-server-path)) -(defmethod initialize-instance :after ((port clx-port) &key) - (let ((options (cdr (port-server-path port)))) - (push (apply #'make-instance 'clx-frame-manager :port port options) - (slot-value port 'frame-managers)) - (setf (slot-value port 'pointer) - (make-instance 'clx-basic-pointer :port port))) - (initialize-clx port)) - (defmethod print-object ((object clx-port) stream) (print-unreadable-object (object stream :identity t :type t) (when (slot-boundp object 'display) diff --git a/Extensions/fonts/mcclim-native-ttf.lisp b/Extensions/fonts/mcclim-native-ttf.lisp index a383d51c..4404bce1 100644 --- a/Extensions/fonts/mcclim-native-ttf.lisp +++ b/Extensions/fonts/mcclim-native-ttf.lisp @@ -558,7 +558,7 @@ of resulting sequence are equal." (invalidate-port-font-cache port)) (defmethod port-all-font-families ((port ttf-port-mixin) &key invalidate-cache preload) - (when invalidate-cache + (when (or (null (font-families port)) invalidate-cache) (invalidate-port-font-cache port) (register-all-ttf-fonts port :preload preload) (register-standard-fonts port :preload preload)) |