Commit 640f90eb authored by Raymond Toy's avatar Raymond Toy

Update to sharplispers/clx commit 021f5d7

parent 60bde987
Pipeline #710 failed with stage
in 18 minutes and 55 seconds
......@@ -116,7 +116,8 @@ Independent FOSS developers"
((:module "demo"
((: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"))))))
This diff is collapsed.
......@@ -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."
......@@ -62,12 +63,10 @@
:border text-color
:background background-color
:save-under :on
:override-redirect :on ;override window mgr when positioning
:event-mask (MAKE-EVENT-MASK :leave-window
;; :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)
(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,6 +147,10 @@
(defun menu-refresh (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))))
......@@ -217,7 +220,7 @@
;; Erase the menu
;; 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
(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
(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)))))
(EVENT-CASE (display :force-output-p t)
(:exposure (count)
;; Display prompt
(when (zerop count)
(:button-press (x y)
;; Pop up the menu
(let ((choice (menu-choose a-menu x y)))
(if choice
(format nil "You have selected ~a." choice)
"No selection...try again."
(otherwise ()
;;Ignore and discard any other event
(CLOSE-DISPLAY display)))))
......@@ -1061,17 +1061,17 @@
;;; :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)
(defun buffer-input-wait-default (display timeout)
#-(or cmu sbcl clisp (and ecl serve-event))
;; 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))
......@@ -1088,9 +1088,9 @@
(sleep fraction) ; Sleep a fraction of a second
(when (listen stream) ; and listen one last time
(return-from buffer-input-wait-default nil)))
#+(or CMU sbcl clisp)
#+(and ecl serve-event)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null number) timeout))
......@@ -1099,18 +1099,34 @@
(cond ((null stream))
((listen stream) nil)
((eql timeout 0) :timeout)
(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)
(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)))
#+(or cmu sbcl clisp)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null number) timeout))
(let ((stream (display-input-stream display)))
(declare (type (or null stream) stream))
(cond ((null stream))
((listen stream) nil)
((eql timeout 0) :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)
(ext:socket-status stream (and timeout sec) (round usec 1d-6)))
#+cmu (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout))
(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.
......@@ -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.")))
(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*
(load (merge-pathnames "defsystem" *clx-source-pathname*))
(if *compile-clx*
(compile-clx *clx-source-pathname* *clx-binary-pathname*)
(load-clx *clx-binary-pathname*))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment