Raymond Toy pushed to branch upstream-clx at cmucl / cmucl Commits: 640f90eb by Raymond Toy at 2018-12-30T01:29:29Z Update to sharplispers/clx commit 021f5d7 - - - - - 5 changed files: - src/clx/clx.asd - src/clx/demo/clx-demos.lisp - src/clx/demo/menu.lisp - src/clx/dependent.lisp - src/clx/provide.lisp Changes: ===================================== src/clx/clx.asd ===================================== @@ -116,7 +116,8 @@ Independent FOSS developers" :components ((:module "demo" :components - ((:file "bezier") + ((:file "menu") + (:file "bezier") (:file "beziertest" :depends-on ("bezier")) (:file "clclock") (:file "clipboard") @@ -126,7 +127,6 @@ Independent FOSS developers" ;; deletion notes. Find out why, and either fix or ;; workaround the problem. (:file "mandel") - (:file "menu") (:file "zoid") (:file "image") (:file "trapezoid" :depends-on ("zoid")))))) ===================================== src/clx/demo/clx-demos.lisp ===================================== @@ -5,9 +5,15 @@ ;;; ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; +;;; CMUCL MP support by Douglas Crosher 1998. +;;; Enhancements including the CLX menu, rewrite of the greynetic +;;; demo, and other fixes by Fred Gilham 1998. +;;; +;;; Backported some changes found in CMUCL repository -- jd 2018-12-29. -(defpackage #:xlib-demo/demos (:use :common-lisp) - (:export do-all-demos demo)) +(defpackage #:xlib-demo/demos + (:use :common-lisp) + (:export #:demo)) (in-package :xlib-demo/demos) @@ -21,6 +27,7 @@ ;;; it is running. (defparameter *demos* nil) +(defparameter *delay* 0.5) (defvar *display* nil) (defvar *screen* nil) @@ -33,105 +40,82 @@ `(progn (defun ,fun-name ,args ,doc - (unless *display* - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp lispworks) - (progn - (setf *display* (xlib::open-default-display)) - (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp lispworks) - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*))) - (let ((*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on))) + (let* ((*display* (or *display* + (xlib:open-default-display) + (xlib:open-display (machine-instance)))) + (*screen* (xlib:display-default-screen *display*)) + (*root* (xlib:screen-root *screen*)) + (*black-pixel* (xlib:screen-black-pixel *screen*)) + (*white-pixel* (xlib:screen-white-pixel *screen*)) + (*window* (xlib:create-window :parent *root* + :x ,x :y ,y + :event-mask '(:visibility-change) + :width ,width :height ,height + :background *white-pixel* + :border *black-pixel* + :border-width 2 + :override-redirect :off))) + (xlib:set-wm-properties *window* + :name ,demo-name + :icon-name ,demo-name + :resource-name ,demo-name + :x ,x :y ,y :width ,width :height ,height + :user-specified-position-p t + :user-specified-size-p t + :min-width ,width :min-height ,height + :width-inc nil :height-inc nil) (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*)))) + ;; Wait until we get mapped before doing anything. + (xlib:display-finish-output *display*) + (unwind-protect (progn ,@forms) + (xlib:display-finish-output *display*) + (xlib:unmap-window *window*)))) (setf (get ',fun-name 'demo-name) ',demo-name) (setf (get ',fun-name 'demo-doc) ',doc) - (export ',fun-name) (pushnew ',fun-name *demos*) ',fun-name)) -;;;; Main entry points. - -(defun do-all-demos () - (loop - (dolist (demo *demos*) - (funcall demo) - (sleep 3)))) - -;;; DEMO is a hack to get by. It should be based on creating a menu. At -;;; that time, *name-to-function* should be deleted, since this mapping will -;;; be manifested in the menu slot name cross its action. Also the -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". -;;; +;;; DEMO (defvar *name-to-function* (make-hash-table :test #'eq)) (defvar *keyword-package* (find-package "KEYWORD")) +(defvar *demo-names* nil) (defun demo () - (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) + (let ((*demo-names* '("Quit"))) (dolist (d *demos*) (setf (gethash (intern (string-upcase (get d 'demo-name)) *keyword-package*) *name-to-function*) - d)) - (loop - (fresh-line) - (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) - (write-string " ") - (write-line "Help <demo name>") - (write-string " ") - (write-line "Quit") - (write-string "Enter demo name: ") - (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - #+mp - (mp:make-process #'(lambda () - (loop - (funcall fun) - (sleep 2))) - :name (format nil "~S" demo)) - #-mp - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) + d) + (push (get d 'demo-name) *demo-names*)) + + (let* ((display (xlib:open-default-display)) + (screen (xlib:display-default-screen display)) + (fg-color (xlib:screen-white-pixel screen)) + (bg-color (xlib:screen-black-pixel screen)) + (nice-font (xlib:open-font display "fixed"))) + + (let ((a-menu (xlib::create-menu + (xlib::screen-root screen) ;the menu's parent + fg-color bg-color nice-font))) + + (setf (xlib::menu-title a-menu) "Please pick your favorite demo:") + (xlib::menu-set-item-list a-menu *demo-names*) + (ignore-errors ;; closing window is not handled properly in menu. + (unwind-protect + (do ((choice (xlib::menu-choose a-menu 100 100) + (xlib::menu-choose a-menu 100 100))) + ((and choice (string-equal "Quit" choice))) + (let* ((demo-choice (intern (string-upcase choice) + *keyword-package*)) + (fun (gethash demo-choice *name-to-function*))) + (setf choice nil) + (when fun + (ignore-errors (funcall fun))))) + (xlib:display-finish-output display) + (xlib:close-display display))))))) ;;;; Shared demo utilities. @@ -143,60 +127,124 @@ (xlib:window-map-state w)))) -;;;; Greynetic. - -;;; GREYNETIC displays random sized and shaded boxes in a window. This is -;;; real slow. It needs work. -;;; -(defun greynetic (window duration) - (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) - (multiple-value-bind (width height) (full-window-state window) - (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) - (xlib:free-gcontext gcontext) - (xlib:free-pixmap pixmap))) - -(defvar *greynetic-pixmap-array* - (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) - -(defun greynetic-pixmapper () - (let ((pixmap-data *greynetic-pixmap-array*)) +(defun make-random-bitmap () + (let ((bitmap-data (make-array '(32 32) :initial-element 0 + :element-type 'xlib::bit))) (dotimes (i 4) (declare (fixnum i)) (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) - pixmap-data)) - -#+nil + (setf nibble (logior nibble (ash nibble 4)) + nibble (logior nibble (ash nibble 8)) + nibble (logior nibble (ash nibble 12)) + nibble (logior nibble (ash nibble 16))) + (dotimes (j 32) + (let ((bit (if (logbitp j nibble) 1 0))) + (setf (aref bitmap-data i j) bit + (aref bitmap-data (+ 4 i) j) bit + (aref bitmap-data (+ 8 i) j) bit + (aref bitmap-data (+ 12 i) j) bit + (aref bitmap-data (+ 16 i) j) bit + (aref bitmap-data (+ 20 i) j) bit + (aref bitmap-data (+ 24 i) j) bit + (aref bitmap-data (+ 28 i) j) bit))))) + bitmap-data)) + + +(defun make-random-pixmap () + (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap)))) + (make-pixmap image 32 32))) + +(defvar *pixmaps* nil) + +(defun make-pixmap (image width height) + (let* ((pixmap (xlib:create-pixmap :width width :height height + :depth 1 :drawable *root*)) + (gc (xlib:create-gcontext :drawable pixmap + :background *black-pixel* + :foreground *white-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height) + (xlib:free-gcontext gc) + pixmap)) + + +;;; +;;; This function returns one of the pixmaps in the *pixmaps* array. +(defun greynetic-pixmapper () + (aref *pixmaps* (random (length *pixmaps*)))) + + +(defun greynetic (window duration) + (let* ((depth (xlib:drawable-depth window)) + (draw-gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel*)) + ;; Need a random state per process. + (*random-state* (make-random-state t)) + (*pixmaps* (let ((pixmap-array (make-array 30))) + (dotimes (i 30) + (setf (aref pixmap-array i) (make-random-pixmap))) + pixmap-array))) + + (unwind-protect + (multiple-value-bind (width height) (full-window-state window) + (declare (fixnum width height)) + (let ((border-x (truncate width 20)) + (border-y (truncate height 20))) + (declare (fixnum border-x border-y)) + (dotimes (i duration) + (let ((pixmap (greynetic-pixmapper))) + (xlib:with-gcontext (draw-gcontext + :foreground (random (ash 1 depth)) + :background (random (ash 1 depth)) + :stipple pixmap + :fill-style + :opaque-stippled) + (cond ((zerop (mod i 500)) + (xlib:clear-area window) + (sleep .1)) + (t + (sleep *delay*))) + (if (< (random 3) 2) + (let* ((w (+ border-x + (truncate (* (random (- width + (* 2 border-x))) + (random width)) width))) + (h (+ border-y + (truncate (* (random (- height + (* 2 border-y))) + (random height)) height))) + (x (random (- width w))) + (y (random (- height h)))) + (declare (fixnum w h x y)) + (if (zerop (random 2)) + (xlib:draw-rectangle window draw-gcontext + x y w h t) + (xlib:draw-arc window draw-gcontext + x y w h 0 (* 2 pi) t))) + (let ((p1-x (+ border-x + (random (- width (* 2 border-x))))) + (p1-y (+ border-y + (random (- height (* 2 border-y))))) + (p2-x (+ border-x + (random (- width (* 2 border-x))))) + (p2-y (+ border-y + (random (- height (* 2 border-y))))) + (p3-x (+ border-x + (random (- width (* 2 border-x))))) + (p3-y (+ border-y + (random (- height (* 2 border-y)))))) + (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y)) + (xlib:draw-lines window draw-gcontext + (list p1-x p1-y p2-x p2-y p3-x p3-y) + :relative-p nil + :fill-p t + :shape :convex))) + (xlib:display-force-output *display*)))))) + (dotimes (i (length *pixmaps*)) + (xlib:free-pixmap (aref *pixmaps* i))) + (xlib:free-gcontext draw-gcontext)))) + + (defdemo greynetic-demo "Greynetic" (&optional (duration 300)) 100 100 600 600 "Displays random grey rectangles." @@ -677,6 +725,7 @@ start-needle end-needle) end-needle) + (sleep *delay*) t) ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE @@ -775,27 +824,28 @@ (when (= prev-neg-velocity 0) (return t)) (let ((negative-velocity (minusp y-velocity))) (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y) + (sleep (/ *delay* 100))) (when (and negative-velocity (>= y-velocity 0)) (setf negative-velocity nil)) (let ((next-x (+ x x-velocity))) @@ -814,7 +864,7 @@ 100 100 300 300 "Drops the demo window with an inital X velocity which bounces off screen borders." - (bounce-window *window* 30)) + (bounce-window *window* 3)) (defdemo bounce-demo "Bounce" () 100 100 300 300 @@ -846,8 +896,8 @@ (multiple-value-bind (width height) (full-window-state window) (xlib:clear-area window) (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output display) - (sleep 4)) + (xlib:display-finish-output display) + (sleep 1)) (xlib:free-gcontext gc))) ;;; Draw points. X assumes points are in the range of width x height, @@ -892,8 +942,8 @@ :function boole-c2 :plane-mask (logxor *white-pixel* *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* + :background *black-pixel* + :foreground *white-pixel* :fill-style :solid)) (rectangles (make-array (* 4 num-rectangles) :element-type 'number @@ -920,6 +970,7 @@ (decf y-off (ash y-dir 1)) (setf y-dir (- y-dir)))) (xlib:draw-rectangles window gcontext rectangles t) + (sleep *delay*) (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) @@ -938,9 +989,12 @@ (defvar *ball-size-x* 38) (defvar *ball-size-y* 34) -(defmacro xor-ball (pixmap window gcontext x y) - `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) +(defun xor-ball (pixmap window gcontext x y) + (xlib:copy-plane pixmap gcontext 1 + 0 0 + *ball-size-x* *ball-size-y* + window + x y)) (defconstant bball-gravity 1) (defconstant maximum-x-drift 7) @@ -1016,7 +1070,7 @@ (defun bounce-balls (display window how-many duration) (xlib:clear-area window) - (xlib:display-force-output display) + (xlib:display-finish-output display) (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) (let* ((balls (do ((i 0 (1+ i)) (list () (cons (make-ball) list))) @@ -1036,16 +1090,16 @@ (xlib:free-gcontext pixmap-gc) (dolist (ball balls) (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-force-output display) + (xlib:display-finish-output display) (dotimes (i duration) (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) + (bounce-1-ball bounce-pixmap window gcontext ball) + (xlib:display-finish-output display)) + (sleep (/ *delay* 50.0))) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) -#+nil (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 34 34 700 500 + 36 34 700 500 "Bouncing balls in space." (bounce-balls *display* *window* how-many duration)) ===================================== src/clx/demo/menu.lisp ===================================== @@ -27,7 +27,8 @@ ;;; | ;;;----------------------------------------------------------------------------------+ - +;;; Some changes are backported from CMUCL CLX source (our implementation had +;;; errors when we tried to use menu). This one is a little shorter. (defstruct (menu) "A simple menu of text strings." @@ -45,29 +46,27 @@ (defun create-menu (parent-window text-color background-color text-font) (make-menu - ;; Create menu graphics context - :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) - ;; Create menu window - :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window - :exposure)))) - - -(defun menu-set-item-list (menu &rest item-strings) + ;; Create menu graphics context + :gcontext (CREATE-GCONTEXT :drawable parent-window + :foreground text-color + :background background-color + :font text-font) + ;; Create menu window + :window (CREATE-WINDOW + :parent parent-window + :class :input-output + :x 0 ;temporary value + :y 0 ;temporary value + :width 16 ;temporary value + :height 16 ;temporary value + :border-width 2 + :border text-color + :background background-color + :save-under :on + ;; :override-redirect :on ;override window mgr when positioning + :event-mask (MAKE-EVENT-MASK :leave-window :exposure)))) + +(defun menu-set-item-list (menu item-strings) ;; Assume the new items will change the menu's width and height (setf (menu-geometry-changed-p menu) t) @@ -148,7 +147,11 @@ (defun menu-refresh (menu) - (let* ((gcontext (menu-gcontext menu)) + (xlib:set-wm-properties (menu-window menu) + :name (menu-title menu) + :icon-name (menu-title menu) + :resource-name (menu-title menu)) + (let* ((gcontext (menu-gcontext menu)) (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) ;; Show title centered in "reverse-video" @@ -217,7 +220,7 @@ t))) ;; Erase the menu - (UNMAP-WINDOW mw) +;;; (UNMAP-WINDOW mw) ;; Return selected item string, if any (unless (eq selected-item :none) selected-item))) @@ -272,111 +275,3 @@ ;; Make menu visible (MAP-WINDOW menu-window))) - -(defun just-say-lisp (&optional (font-name "fixed")) - (let* ((display (open-default-display)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - (a-menu (create-menu (screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) - - (setf (menu-title a-menu) "Please pick your favorite language:") - (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") - - ;; Bedevil the user until he picks a nice programming language - (unwind-protect - (do (choice) - ((and (setf choice (menu-choose a-menu 100 100)) - (string-equal "Lisp" choice)))) - - (CLOSE-DISPLAY display)))) - - -(defun pop-up (host strings &key (title "Pick one:") (font "fixed")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (font (OPEN-FONT display font)) - (parent-width 400) - (parent-height 400) - (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on - :x 100 :y 100 - :width parent-width :height parent-height - :background bg-color - :event-mask (MAKE-EVENT-MASK :button-press - :exposure))) - (a-menu (create-menu parent fg-color bg-color font)) - (prompt "Press a button...") - (prompt-gc (CREATE-GCONTEXT :drawable parent - :foreground fg-color - :background bg-color - :font font)) - (prompt-y (FONT-ASCENT font)) - (ack-y (- parent-height (FONT-DESCENT font)))) - - (setf (menu-title a-menu) title) - (apply #'menu-set-item-list a-menu strings) - - ;; Present main window - (MAP-WINDOW parent) - - (flet ((display-centered-text - (window string gcontext height width) - (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) - (declare (ignore a d l r)) - (let ((box-height (+ fa fd))) - - ;; Clear previous text - (CLEAR-AREA window - :x 0 :y (- height fa) - :width width :height box-height) - - ;; Draw new text - (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) - - (unwind-protect - (loop - (EVENT-CASE (display :force-output-p t) - - (:exposure (count) - - ;; Display prompt - (when (zerop count) - (display-centered-text - parent - prompt - prompt-gc - prompt-y - parent-width)) - t) - - (:button-press (x y) - - ;; Pop up the menu - (let ((choice (menu-choose a-menu x y))) - (if choice - (display-centered-text - parent - (format nil "You have selected ~a." choice) - prompt-gc - ack-y - parent-width) - - (display-centered-text - parent - "No selection...try again." - prompt-gc - ack-y - parent-width))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - (CLOSE-DISPLAY display))))) - ===================================== src/clx/dependent.lisp ===================================== @@ -1061,36 +1061,56 @@ ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation - -;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or CMU sbcl) -(defparameter *buffer-read-polling-time* 0.5) - -#-(or CMU sbcl clisp) +#-(or cmu sbcl clisp (and ecl serve-event)) +(progn + ;; Issue a warning to incentivize providing better implementation. + (eval-when (:compile-toplevel :load-toplevel :execute) + (warn "XLIB::BUFFER-INPUT-WAIT-DEFAULT: timeout polling used.")) + ;; Poll for input every *buffer-read-polling-time* SECONDS. + (defparameter *buffer-read-polling-time* 0.01) + (defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (listen stream) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (listen stream) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout)))))) + +#+(and ecl serve-event) (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - + (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -#+(or CMU sbcl clisp) + ((eql timeout 0) :timeout) + (T (flet ((usable! (fd) + (declare (ignore fd)) + (return-from buffer-input-wait-default))) + (serve-event:with-fd-handler ((ext:file-stream-fd + (typecase stream + (two-way-stream (two-way-stream-input-stream stream)) + (otherwise stream))) + :input #'usable!) + (serve-event:serve-event timeout))) + :timeout)))) + +#+(or cmu sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) @@ -1099,18 +1119,14 @@ (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) - (t - (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) - :input timeout) - #+mp (mp:process-wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) + ;; MP package protocol may be shared between clisp and cmu. + ((or #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) + #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) - (ext:socket-status stream (and timeout sec) - (round usec 1d-6))) - #-(or sbcl mp clisp) (system:wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - nil - :timeout))))) + (ext:socket-status stream (and timeout sec) (round usec 1d-6))) + #+cmu (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout)) + nil) + (T :timeout)))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ===================================== src/clx/provide.lisp ===================================== @@ -17,35 +17,3 @@ (in-package :common-lisp-user) (provide :clx) - -(defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) - -(defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) - -(defvar *compile-clx* - nil) - -(load (merge-pathnames "defsystem" *clx-source-pathname*)) - -(if *compile-clx* - (compile-clx *clx-source-pathname* *clx-binary-pathname*) - (load-clx *clx-binary-pathname*)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/640f90eba0b045c93c116fa55e... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/640f90eba0b045c93c116fa55e... You're receiving this email because of your account on gitlab.common-lisp.net.