December 2018 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] Merge with sharplispers/clx commit 021f5d7
by Raymond Toy 30 Dec '18

30 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: ab34d94e by Raymond Toy at 2018-12-30T01:53:39Z Merge with 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,38 +17,3 @@ (in-package :common-lisp-user) (provide :clx) - -#-cmu -(progn -(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*)) -) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ab34d94e0f317fa75f8b5b87b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ab34d94e0f317fa75f8b5b87b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] 3 commits: Fix #73: Update clx from upstream clx
by Raymond Toy 30 Dec '18

30 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: 6453d716 by Raymond Toy at 2018-12-17T17:30:57Z Fix #73: Update clx from upstream clx - - - - - 04c1bee3 by Raymond Toy at 2018-12-17T17:30:57Z Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master' Fix #73: Update clx from upstream clx Closes #73 See merge request cmucl/cmucl!44 - - - - - f269c092 by Raymond Toy at 2018-12-30T01:29:59Z Merge branch 'master' into rtoy-update-clx-with-cmucl-fixes - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5e075fa01a55c4022fa9277b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5e075fa01a55c4022fa9277b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][upstream-clx] Update to sharplispers/clx commit 021f5d7
by Raymond Toy 30 Dec '18

30 Dec '18

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/640f90eba0b045c93c116fa55… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/640f90eba0b045c93c116fa55… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #73: Update clx from upstream clx
by Raymond Toy 17 Dec '18

17 Dec '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6453d716 by Raymond Toy at 2018-12-17T17:30:57Z Fix #73: Update clx from upstream clx - - - - - 04c1bee3 by Raymond Toy at 2018-12-17T17:30:57Z Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master' Fix #73: Update clx from upstream clx Closes #73 See merge request cmucl/cmucl!44 - - - - - 29 changed files: - src/clx/CHANGES - src/clx/NEWS - src/clx/README-R5 - + src/clx/README.md - + src/clx/ci-doc-gh-pages.sh - src/clx/clx.asd - src/clx/debug/debug.lisp - src/clx/debug/describe.lisp - src/clx/debug/event-test.lisp - src/clx/debug/keytrans.lisp - src/clx/debug/trace.lisp - src/clx/debug/util.lisp - + src/clx/demo/image.lisp - + src/clx/demo/trapezoid.lisp - src/clx/dep-allegro.lisp - src/clx/dep-lispworks.lisp - src/clx/dep-openmcl.lisp - src/clx/depdefs.lisp - src/clx/dependent.lisp - src/clx/exclMakefile - src/clx/exclREADME - src/clx/excldep.c - + src/clx/extensions/composite.lisp - + src/clx/extensions/dbe.lisp - + src/clx/extensions/dri2.lisp - + src/clx/extensions/randr.lisp - src/clx/extensions/shape.lisp - + src/clx/extensions/xc-misc.lisp - src/clx/extensions/xrender.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d94877687e6deab2f08d066f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d94877687e6deab2f08d066f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix some incorrect markdown markup
by Raymond Toy 17 Dec '18

17 Dec '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 15655145 by Raymond Toy at 2018-12-10T15:02:13Z Fix some incorrect markdown markup - - - - - d9487768 by Raymond Toy at 2018-12-10T15:55:54Z More markup fixes - - - - - 1 changed file: - BUILDING.md Changes: ===================================== BUILDING.md ===================================== @@ -12,13 +12,13 @@ General Requirements In order to build CMU CL, you will need: -a. A working CMU CL binary. There is no way around this requirement! +1. A working CMU CL binary. There is no way around this requirement! This binary can either be for the platform you want to target, in that case you can either recompile or cross-compile, or for another supported platform, in that case you must cross-compile, obviously. -a. A supported C compiler for the C runtime code. +1. A supported C compiler for the C runtime code. Most of the time, this means GNU gcc, though for some ports it means the vendor-supplied C compiler. The compiler must be @@ -27,13 +27,13 @@ a. A supported C compiler for the C runtime code. Note for FreeBSD 10 and above: The build requires gcc (Clang will not work) and the lib32 compatiblity package. -a. GNU make +1. GNU make This has to be available either as gmake or make in your PATH, or the MAKE environment variable has to be set to point to the correct binary. -a. The CMU CL source code +1. The CMU CL source code Here you can either use one of the release source tarballs, or check out the source code directly from the public CMUCL git @@ -48,16 +48,19 @@ Setting up a build environment ------------------------------ 1. Create a base directory and change to it - +``` mkdir cmucl ; cd cmucl - -2.) Fetch the sources and put them into the base directory - +``` +2. Fetch the sources and put them into the base directory +``` tar xzf /tmp/cmucl-source.tar.gz +``` or, if you want to use the git sources directly: +``` git clone https://gitlab.common-lisp.net/cmucl/cmucl.git +``` Whatever you do, the sources must be in a directory named src inside the base directory. Since the build tools keep all @@ -81,7 +84,9 @@ quick guide. Use this to build from a version of CMUCL that is very close to the sources you are trying to build now: +``` bin/build.sh -C "" -o "<name-of-old-lisp> <options-to-lisp>" +``` This will build CMUCL 3 times, each time with the result of the previous build. The last time, the additional libraries like CLX, @@ -100,7 +105,9 @@ quick guide. For these, you can use this: +``` bin/build.sh -C "" -o "<old-lisp>" -B boot1.lisp -B boot2.lisp +``` The bootstrap files listed with the -B option (as many as needed) are loaded in order, so be sure to get them right. @@ -121,9 +128,9 @@ file date of a boot file is later than the version of CMUCL you are building from, then you need to use b) or c) above. You may need to read the bootfiles for additional instructions, if any. -If there are no bootfiles, then you can use a) above. +If there are no bootfiles, then you can use 1. above. -The build.sh script supports other options, and bin/build.sh -? +The `build.sh` script supports other options, and `bin/build.sh -?` will give a quick summary. Read bin/build.sh for more information. @@ -247,195 +254,197 @@ Overview of the included build scripts * bin/build.sh [-123obvuBCU?] -This is the main build script. It essentially calls the other build -scripts described below in the proper sequence to build cmucl from an -existing binary of cmucl. + This is the main build script. It essentially calls the other build + scripts described below in the proper sequence to build cmucl from an + existing binary of cmucl. * bin/create-target.sh target-directory [lisp-variant [motif-variant]] -This script creates a new target directory, which is a shadow of the -source directory, that will contain all the files that are created by -the build process. Thus, each target's files are completely separate -from the src directory, which could, in fact, be read-only. Hence you -can simultaneously build CMUCL for different targets from the same -source directory. - -The first argument is the name of the target directory to create. The -remaining arguments are optional. If they are not given, the script -tries to determine the lisp variant and motif variant from the system -the script is running on. - -The lisp-variant (i.e. the suffix of the src/lisp/Config.* to use as -the target's Config file), and optionally the motif-variant (again the -suffix of the src/motif/server/Config.* file to use as the Config file -for the target's CMUCL/Motif server code). If the lisp-variant is -given but the motif-variant is not, the motif-variant is determined -from the lisp-variant. - -The script will generate the target directory tree, link the relevant -Config files, and generate place-holder files for various files, in -order to ensure proper operation of the other build-scripts. It also -creates a sample setenv.lisp file in the target directory, which is -used by the build and load processes to set up the correct list of -*features* for your target lisp core. - -IMPORTANT: You will normally NOT have to modify the sample setenv.lisp -file, if you are building from a binary that has the desired features. -In fact, the sample has all code commented out, If you want to add or -remove features, you need to include code that puts at least a minimal -set of features onto the list (use PUSHNEW and/or REMOVE). You can -use the current set of *features* of your lisp as a first guide. The -sample setenv.lisp includes a set of features that should work for the -intended configuration. Note also that some adding or removing some -features may require a cross-compile instead of a normal compile. + This script creates a new target directory, which is a shadow of the + source directory, that will contain all the files that are created by + the build process. Thus, each target's files are completely separate + from the src directory, which could, in fact, be read-only. Hence you + can simultaneously build CMUCL for different targets from the same + source directory. + + The first argument is the name of the target directory to create. The + remaining arguments are optional. If they are not given, the script + tries to determine the lisp variant and motif variant from the system + the script is running on. + + The lisp-variant (i.e. the suffix of the src/lisp/Config.* to use as + the target's Config file), and optionally the motif-variant (again the + suffix of the src/motif/server/Config.* file to use as the Config file + for the target's CMUCL/Motif server code). If the lisp-variant is + given but the motif-variant is not, the motif-variant is determined + from the lisp-variant. + + The script will generate the target directory tree, link the relevant + Config files, and generate place-holder files for various files, in + order to ensure proper operation of the other build-scripts. It also + creates a sample setenv.lisp file in the target directory, which is + used by the build and load processes to set up the correct list of + *features* for your target lisp core. + + IMPORTANT: You will normally NOT have to modify the sample setenv.lisp + file, if you are building from a binary that has the desired features. + In fact, the sample has all code commented out, If you want to add or + remove features, you need to include code that puts at least a minimal + set of features onto the list (use PUSHNEW and/or REMOVE). You can + use the current set of *features* of your lisp as a first guide. The + sample setenv.lisp includes a set of features that should work for the + intended configuration. Note also that some adding or removing some + features may require a cross-compile instead of a normal compile. * bin/clean-target.sh [-l] target-directory [more dirs] -Cleans the given target directory, so that all created files will be -removed. This is useful to force recompilation. If the -l flag is -given, then the C runtime is also removed, including all the lisp -executable, any lisp cores, all object files, lisp.nm, internals.h, -and the config file. + Cleans the given target directory, so that all created files will be + removed. This is useful to force recompilation. If the -l flag is + given, then the C runtime is also removed, including all the lisp + executable, any lisp cores, all object files, lisp.nm, internals.h, + and the config file. * bin/build-world.sh target-directory [build-binary] [build-flags...] -Starts a complete world build for the given target, using the lisp -binary/core specified as a build host. The recompilation step will -only recompile changed files, or files for which the fasl files are -missing. It will also not recompile the C runtime code (the lisp -binary). If a (re)compilation of that code is needed, the genesis -step of the world build will inform you of that fact. In that case, -you'll have to use the rebuild-lisp.sh script, and then restart the -world build process with build-world.sh + Starts a complete world build for the given target, using the lisp + binary/core specified as a build host. The recompilation step will + only recompile changed files, or files for which the fasl files are + missing. It will also not recompile the C runtime code (the lisp + binary). If a (re)compilation of that code is needed, the genesis + step of the world build will inform you of that fact. In that case, + you'll have to use the rebuild-lisp.sh script, and then restart the + world build process with build-world.sh * bin/rebuild-lisp.sh target-directory -This script will force a complete recompilation of the C runtime code -of CMU CL (aka the lisp executable). Doing this will necessitate -building a new kernel.core file, using build-world.sh. + This script will force a complete recompilation of the C runtime code + of CMU CL (aka the lisp executable). Doing this will necessitate + building a new kernel.core file, using build-world.sh. * bin/load-world.sh target-directory version -This will finish the CMU CL rebuilding process, by loading the -remaining compiled files generated in the world build process into the -kernel.core file, that also resulted from that process, creating the -final lisp.core file. + This will finish the CMU CL rebuilding process, by loading the + remaining compiled files generated in the world build process into the + kernel.core file, that also resulted from that process, creating the + final lisp.core file. -You have to pass the version string as a second argument. The dumped -core will anounce itself using that string. Please don't use a string -consisting of an official release name only, (e.g. "18d"), since those -are reserved for official release builds. Including the build-date in -ISO8601 format is often a good idea, e.g. "18d+ 2002-05-06" for a -binary that is based on sources current on the 6th May, 2002, which is -post the 18d release. + You have to pass the version string as a second argument. The dumped + core will anounce itself using that string. Please don't use a string + consisting of an official release name only, (e.g. "18d"), since those + are reserved for official release builds. Including the build-date in + ISO8601 format is often a good idea, e.g. "18d+ 2002-05-06" for a + binary that is based on sources current on the 6th May, 2002, which is + post the 18d release. * bin/build-utils.sh target-directory -This script will build auxiliary libraries packaged with CMU CL, -including CLX, CMUCL/Motif, the Motif debugger, inspector, and control -panel, and the Hemlock editor. It will use the lisp executable and -core of the given target. + This script will build auxiliary libraries packaged with CMU CL, + including CLX, CMUCL/Motif, the Motif debugger, inspector, and control + panel, and the Hemlock editor. It will use the lisp executable and + core of the given target. -Note: To build with Motif (clm), you need to have the Motif libraries -available and headers available to build motifd, the clm Motif server. -OpenMotif is known to work. + Note: To build with Motif (clm), you need to have the Motif libraries + available and headers available to build motifd, the clm Motif server. + OpenMotif is known to work. -You may need to adjust the include paths and library paths in -src/motif/server/Config.* to match where Motif is installed if the -paths therein are incorrect. + You may need to adjust the include paths and library paths in + src/motif/server/Config.* to match where Motif is installed if the + paths therein are incorrect. -Unless you intend to use clm and motifd, you can safely ignore the -build failure. Everything else will have been compiled correctly; you -just can't use clm. + Unless you intend to use clm and motifd, you can safely ignore the + build failure. Everything else will have been compiled correctly; you + just can't use clm. * bin/make-dist.sh [-bg] [-G group] [-O owner] target-directory version arch os -This script creates both main and extra distribution tarballs from the -given target directory, using the make-main-dist.sh and -make-extra-dist.sh scripts. The result will be two tar files. One -contains the main distribution including the runtime and lisp.core -with PCL (CLOS); the second contains the extra libraries such as -Gray-streams, simple-streams, CLX, CLM, and Hemlock. + This script creates both main and extra distribution tarballs from the + given target directory, using the make-main-dist.sh and + make-extra-dist.sh scripts. The result will be two tar files. One + contains the main distribution including the runtime and lisp.core + with PCL (CLOS); the second contains the extra libraries such as + Gray-streams, simple-streams, CLX, CLM, and Hemlock. -Some options that are available: + Some options that are available: - -b Use bzip2 compression - -g Use gzip compression - -G group Group to use - -O owner Owner to use + -b Use bzip2 compression + -g Use gzip compression + -G group Group to use + -O owner Owner to use -If you specify both -b and -g, you will get two sets of tarfiles. The --G and -O options will attempt to set the owner and group of the files -when building the tarfiles. This way, when you extract the tarfiles, -the owner and group will be set as specified. You may need to be root -to do this because many Unix systems don't normally let you change the -owner and group of a file. + If you specify both -b and -g, you will get two sets of tarfiles. The + -G and -O options will attempt to set the owner and group of the files + when building the tarfiles. This way, when you extract the tarfiles, + the owner and group will be set as specified. You may need to be root + to do this because many Unix systems don't normally let you change the + owner and group of a file. -The remaining arguments used to create the name of the tarfiles. The -names will have the form: + The remaining arguments used to create the name of the tarfiles. The + names will have the form: +``` cmucl-<version>-<arch>-<os>.tar.bz2 cmucl-<version>-<arch>-<os>.extras.tar.bz2 +``` -Of course, the "bz2" will be "gz" if you specified gzip compression -instead of bzip. + Of course, the "bz2" will be "gz" if you specified gzip compression + instead of bzip. * /bin/make-main-dist.sh target-directory version arch os -This is script is not normally invoked by the user; make-dist will do -it appropriately. + This is script is not normally invoked by the user; make-dist will do + it appropriately. -This script creates a main distribution tarball (both in gzipped and -bzipped variants) from the given target directory. This will include -all the stuff that is normally included in official release tarballs -such as lisp.core and the PCL libraries, including Gray streams and -simple streams. + This script creates a main distribution tarball (both in gzipped and + bzipped variants) from the given target directory. This will include + all the stuff that is normally included in official release tarballs + such as lisp.core and the PCL libraries, including Gray streams and + simple streams. -This is intended to be run from make-dist.sh. + This is intended to be run from make-dist.sh. * bin/make-extra-dist.sh target-directory version arch os -This is script is not normally invoked by the user; make-dist will do -it appropriately. + This is script is not normally invoked by the user; make-dist will do + it appropriately. -This script creates an extra distribution tarball (both in gzipped and -bzipped variants) from the given target directory. This will include -all the stuff that is normally included in official extra release -tarballs, i.e. the auxiliary libraries such as CLX, CLM, and Hemlock. + This script creates an extra distribution tarball (both in gzipped and + bzipped variants) from the given target directory. This will include + all the stuff that is normally included in official extra release + tarballs, i.e. the auxiliary libraries such as CLX, CLM, and Hemlock. -This is intended to be run from make-dist.sh. + This is intended to be run from make-dist.sh. * cross-build-world.sh target-directory cross-directory cross-script [build-binary] [build-flags...] -This is a script that can be used instead of build-world.sh for -cross-compiling CMUCL. In addition to the arguments of build-world.sh -it takes two further required arguments: The name of a directory that -will contain the cross-compiler backend (the directory is created if -it doesn't exist, and must not be the same as the target-directory), -and the name of a Lisp cross-compilation script, which is responsible -for setting up, compiling, and loading the cross-compiler backend. -The latter argument is needed because each host/target combination of -platform's needs slightly different code to produce a working -cross-compiler. - -We include a number of working examples of cross-compiler scripts in -the cross-scripts directory. You'll have to edit the features section -of the given scripts, to specify the features that should be removed -from the current set of features in the host lisp, and those that -should be added, so that the backend features are correct for the -intended target. - -You can look at Eric Marsden's collection of build scripts for the -basis of more cross-compiler scripts. + This is a script that can be used instead of build-world.sh for + cross-compiling CMUCL. In addition to the arguments of build-world.sh + it takes two further required arguments: The name of a directory that + will contain the cross-compiler backend (the directory is created if + it doesn't exist, and must not be the same as the target-directory), + and the name of a Lisp cross-compilation script, which is responsible + for setting up, compiling, and loading the cross-compiler backend. + The latter argument is needed because each host/target combination of + platform's needs slightly different code to produce a working + cross-compiler. + + We include a number of working examples of cross-compiler scripts in + the cross-scripts directory. You'll have to edit the features section + of the given scripts, to specify the features that should be removed + from the current set of features in the host lisp, and those that + should be added, so that the backend features are correct for the + intended target. + + You can look at Eric Marsden's collection of build scripts for the + basis of more cross-compiler scripts. Step-by-Step Example of recompiling CMUCL for OpenBSD ----------------------------------------------------- Set up everything as described in the setup section above. Then execute: - +``` # Create a new target directory structure/config for OpenBSD: bin/create-target.sh openbsd OpenBSD_gencgc OpenBSD @@ -487,10 +496,12 @@ bin/load-world.sh openbsd "18d+ 2002-05-06" # core will announce. Please always put the build-date and some # other information in there, to make it possible to differentiate # those builds from official builds, which only contain the release. +``` Now you should have a new lisp.core, which you can start with - +``` ./openbsd/lisp/lisp -core ./openbsd/lisp/lisp.core -noinit -nositeinit +``` Compiling sources that contain disruptive changes ------------------------------------------------- @@ -693,4 +704,4 @@ In particular steps 3, 4, and 5 can be combined into one by using the -c, -r, and -l options for cross-build-world.sh. The -c option cleans out the targe and cross directories; -r does step 4; and -l does step 5. -=============== + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/cb825da9cf7aff8f96b81ca7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/cb825da9cf7aff8f96b81ca7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] 73 commits: Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master'
by Raymond Toy 17 Dec '18

17 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: b464fc94 by Raymond Toy at 2018-01-27T19:52:26Z Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master' Update clx from upstream Closes #50 See merge request cmucl/cmucl!31 - - - - - b8841170 by Raymond Toy at 2018-01-27T21:04:52Z Fix #49: CLM crashes When invoking motifd, the program name is #p:'library:motifd". This is passed directly to spawn (a C routine), which only accepts strings. So, before calling spawn, convert the program path to a unix namestring. This allows the example from the bug to run without crashing. - - - - - 87c07e5d by Raymond Toy at 2018-01-28T02:19:56Z Make sure spawn is called with a string The previous commit worked for search lists, but the program could be a string. Take care to convert pathnames to strings so that spawn is always called with a string. - - - - - 99eb4311 by Raymond Toy at 2018-01-28T02:54:17Z Merge branch 'rtoy-fix-49-clm-crash' into 'master' Fix #49: CLM crashes Closes #49 See merge request cmucl/cmucl!32 - - - - - 380759e3 by Raymond Toy at 2018-01-28T05:59:25Z Restore ability to compile in mt19937 rng. - src/tools/worldbuild.lisp - only compile rand-xoroshiro if :random-xoroshiro is a feature - src/tools/worldload.lisp - only load rand-xoroshiro if :random-xoroshiro is a feature - tests/rng.lisp - Add a quick test that the state vector of the *random-state* has the correct type. - - - - - dc4a7e00 by Raymond Toy at 2018-01-29T02:20:20Z Fix #47: Print backquote multiple splices correctly * Print multiple splices correclty without the extra set of parenthesis around each splice. * Add test for this. - - - - - e7f97a5d by Raymond Toy at 2018-01-30T03:04:30Z Merge branch 'rtoy-fix-47-backq-splice-printer' into 'master' Fix #47: Print backquote multiple splices correctly Closes #47 See merge request cmucl/cmucl!33 - - - - - 3acdd1b7 by Raymond Toy at 2018-02-03T16:57:28Z Fix #59: type derivation for decode-float exponent Type derivation for exponent part of decode-float was incorrect. We need to take the absolute value of the argument before deriving the type since the exponent is, of course, independent of the sign of the number. In the test case, the negative interval caused the lower and upper bounds to be reversed, resulting in an invalid interval. - - - - - 62c5f3e9 by Raymond Toy at 2018-02-03T17:03:04Z Add test for issue #59. - - - - - 2292400e by Raymond Toy at 2018-02-04T16:16:35Z Fix typo. double-double-float is in the kernel package - - - - - 4e58e53c by Raymond Toy at 2018-02-04T16:19:13Z Be more careful in computing the decode-float bounds If 0 is the lower bound then the smallest exponent is not for 0, but for the least positive float because of denormals. Also handle exclusive bounds. - - - - - 7b336362 by Raymond Toy at 2018-02-04T16:19:37Z Add more tests decode-float. - - - - - 90df7817 by Raymond Toy at 2018-02-04T18:46:50Z Merge branch 'rtoy-fix-59-derive-decode-float' into 'master' Fix #59: derive decode float Closes #59 See merge request cmucl/cmucl!34 - - - - - 894e18e0 by Raymond Toy at 2018-02-10T16:52:20Z Update from logs - - - - - e3c4759d by Philip Fominykh at 2018-02-13T05:20:33Z Restore hevea support for buliding cmu-user - - - - - 3be1f5ba by Philip Fominykh at 2018-02-13T05:22:15Z Improved function signature rendering in cmu-user html version - - - - - 26e3ad82 by Raymond Toy at 2018-02-18T03:44:02Z Fix #60: `C::%UNARY-FROUND` is undefined Remove the symbol `C::%UNARY-FROUND` and just let the compiler package inherit it from the kernel package. * src/bootfiles/21c/boot-2018-02-1.lisp * Use this to bootstrap the change (by uninterning the symbol) * src/code/float.lisp * Just export %unary-fround * src/general-info/release-21d.md * Update * tests/issues.lisp * Add test for this issue - - - - - 84d9a4bd by Raymond Toy at 2018-02-18T03:56:32Z Oops. Need to build with the bootstrap file. - - - - - 31c6bf9f by Raymond Toy at 2018-02-18T15:30:51Z Merge branch 'rtoy-fix-60-unary-fround-undefined' into 'master' Fix #60: unary fround undefined Closes #60 See merge request cmucl/cmucl!36 - - - - - bccd6a98 by Raymond Toy at 2018-02-18T17:01:08Z Fix #58: Bogus type error in comparison of complex number with `THE` form The deftransforms `upgraded-complex-real-contagion-arg1` and `upgraded-complex-real-contagion-arg2` were coercing the complex number to the exact type of the float number. Because of the `THE` form, the type of the float was `(member 1d0)`, so the compiler was coercing `#c(1/2 1/2)` to `(complex (double-float 1d0))`, which is wrong. Therefore, coerce the complex to just the type format of the real part, ignoring any bounds. * src/compiler/float-tran.lisp * Coerce to format type, discarding any bounds * src/general-info/release-21d.md * Update notes * tests/issues.lisp * Added test for this - - - - - 771fd903 by Raymond Toy at 2018-02-18T17:11:19Z Merge branch 'rtoy-fix-issue-58' into 'master' Fix #58: Bogus type error in comparison of complex number with `THE` form Closes #58 See merge request cmucl/cmucl!37 - - - - - e9a598e5 by Raymond Toy at 2018-02-19T16:41:07Z Complex array accessors are not foldable Fixes #61 and #62. The `ARRAY-HAS-FILL-POINTER-P` and `ARRAY-DISPLACEMENT` functions are declared inline and the compiler tries to constant-fold these inlined functions operating on simple arrays. Thus don't allow the compiler to constant-fold calls to `%ARRAY-FILL-POINTER-P`. This is normally protected by a call to `ARRAY-HEADER-P`, but when it's inlined, the compiler tries to constant-fold `%ARRAY-FILL-POINTER-P` on an array without such a slot. Likewise `ARRAY-DISPLACEMENT` calls `%ARRAY-DISPLACED-P`, `%ARRAY-DATA-VECTOR`, and `%ARRAY-DISPLACEMENT`, and the calls are protected by `ARRAY-HEADER-P`. So don't constant-fold these either. Maybe we could also make CONSTANT-FOLD-CALL be smarter about this? * src/compiler/generic/objdef.lisp * Remove flushable from these ref-trans methods. * src/general-info/release-21d.md * Update * tests/issues.lisp * Add tests from the bug reports. - - - - - ac4b9fc8 by Raymond Toy at 2018-02-19T16:50:47Z Merge branch 'rtoy-fix-61-62-not-flushable' into 'master' Complex array accessors are not foldable Closes #61 and #62 See merge request cmucl/cmucl!38 - - - - - 3c56ed8c by Raymond Toy at 2018-03-03T22:28:53Z Remove test files from tests The tests create some files in /tmp. Remove them when the test script ends so that we get a clean directory. I think this fixes the issue with the osx-runner sometimes failing because it can't remove the temp files that I created locally when testing locally. - - - - - 52a93a05 by Raymond Toy at 2018-03-03T22:30:47Z Use the 2018-03 snapshots for testing. - - - - - ccd159f1 by Philip Fominykh at 2018-03-05T05:59:37Z Remove extra paragraph generation in Hevea definitions. Added argument #5 to \layout to act as prelude. Putting index and spacing commands there eliminates extra paragraph. - - - - - 7b9be9a8 by Philip Fominykh at 2018-03-05T06:01:53Z Hevea cmu-user generation cleanups. - - - - - 9b55c3e4 by Philip Fominykh at 2018-03-05T06:03:02Z Merge branch 'master' into pfominykh-cmu-user-fixes - - - - - efc3d8c5 by Raymond Toy at 2018-03-06T04:18:37Z Merge branch 'pfominykh-cmu-user-fixes' into 'master' Restore hevea support for cmu-user See merge request cmucl/cmucl!35 - - - - - 3c749f8b by Raymond Toy at 2018-03-14T22:47:15Z Update manual date to 21c Just change the date on the manual to the date of the 21c release. Now that we can create the html pages again with hevea, we can update this. - - - - - 23e31483 by Raymond Toy at 2018-05-12T17:40:12Z ASDF 3.3.2 - - - - - 90d8b4b5 by Raymond Toy at 2018-07-04T16:54:08Z Bignum multiply without consing temp space The current bignum multiplier creates temp space to hold the absolute value of the bignums and then negates the result (in-place) at the end. Instead, use the algorithm from Hacker's Delight that pretends the numbers are unsigned, does the unsigned multiply and finally corrects the result. No extra memory is needed for this. - - - - - e6b95b82 by Raymond Toy at 2018-07-04T19:21:25Z Add simple test - - - - - 3af22f92 by Raymond Toy at 2018-07-04T19:40:30Z Add some timing code, but not for tests. - - - - - d652bd09 by Raymond Toy at 2018-07-04T20:31:21Z Rename functions to use the new version by default. Update tests to reflect the change in names. - - - - - be073d06 by Raymond Toy at 2018-07-07T17:41:33Z Use fixed ubuntu image - - - - - 01fa37d8 by Raymond Toy at 2018-07-07T19:01:45Z Use Ubuntu 14.04 Let's see if 14.04 works better. I don't feel like debugging the test failure in a VM right now. And I don't want to set up everything to use Fedora (which is what my linux box is running). - - - - - 0f0ac0b6 by Raymond Toy at 2018-07-15T17:45:08Z Add tests with fixed operands - - - - - 228359b6 by Raymond Toy at 2018-07-15T20:47:44Z Refactor common code into a routine The code for applying the correction is pretty much identical for each negative operant, so add a routine to do that. - - - - - cb6e99a3 by Raymond Toy at 2018-07-15T23:01:01Z Disable test issue.41.1 - - - - - 833fef6d by Raymond Toy at 2018-07-16T00:04:01Z Merge branch 'rtoy-bignum-mult-less-consing' into 'master' Reduce consing in bignum multiplier See merge request cmucl/cmucl!39 - - - - - 50b1201e by Raymond Toy at 2018-07-18T05:06:14Z Use ubuntu 16.04 image for testing - - - - - 05f11fa5 by Raymond Toy at 2018-07-21T03:38:57Z Issue #64: Disable test when running CI - - - - - 576fc79d by Raymond Toy at 2018-07-21T03:38:57Z Merge branch 'rtoy-issue-64' into 'master' Issue #64: Disable test when running CI See merge request cmucl/cmucl!40 - - - - - 0a2e45d4 by Raymond Toy at 2018-07-22T01:03:44Z Default RNG for x86 and sparc is :random-xoroshiro Replace :random-mt19937 with :random-xoroshiro in the cross-compile scripts. - - - - - 4915f467 by Raymond Toy at 2018-07-22T17:14:55Z Remove unused vars in WITH-FLOAT-TRAPS macro* The TRAPS and EXCEPTION vars in the WITH-FLOAT-TRAPS were unused. Remove them. Also add some tests for WITH-FLOAT-TRAPS-MASKED to verify that the traps are masked. - - - - - 0c427fc1 by Raymond Toy at 2018-07-27T17:51:02Z Remove extra closing paren - - - - - cb251bbe by Raymond Toy at 2018-08-05T01:46:45Z Export more symbols in defpackage for xlib. The compiler complained that these symbols were also being exported from the XLIB package. Just add them to the defpackage to silence the warnings. - - - - - 7c79326d by Raymond Toy at 2018-08-05T01:50:55Z Add %UNARY-FROUND to exports of defpackage for KERNEL. - - - - - 2de12cd7 by Raymond Toy at 2018-08-05T23:46:44Z Fix compiler warning clang complains: warning: incompatible pointer to integer conversion passing 'lispobj *' (aka 'unsigned long *') to parameter of type 'lispobj' (aka 'unsigned long'); dereference with * [-Wint-conversion] || in_range_p(addr, control_stack, control_stack_size) So cast control_stack to lispobj. Same complaint for binding_stack too. - - - - - 7a6a0e19 by Raymond Toy at 2018-08-23T00:16:10Z Add template for Bugs - - - - - 1894fbfe by Raymond Toy at 2018-08-23T00:19:24Z Add template for Feature requests - - - - - 14f72f54 by Raymond Toy at 2018-08-23T00:26:05Z Set label correctly. It's a tilde, not dash. - - - - - 1d6d12de by Raymond Toy at 2018-08-23T00:27:01Z Set label to feature - - - - - 82bf2c72 by Raymond Toy at 2018-08-25T23:51:54Z Add support for compiling with clang on x86/linux Add `Config.x86_linux_clang` to use clang instead of gcc to build cmucl. update `create-target.sh` so that it sets the motif variant correctly when using `Config.x86_linux_clang` See issue #68. With this config, Fedora 28 successfully builds cmucl and passes all the tests. - - - - - 9d2590c0 by Raymond Toy at 2018-08-28T22:00:19Z Get rid of FPU_MODE This was used to selecte whether we were building for x87 or sse2, but we dropped support for x87 a long while ago. Remove this var. - - - - - d7f49e51 by Raymond Toy at 2018-09-01T16:53:24Z Oops. Forgot to remove one more FPU_MODE - - - - - 7b4e019d by Raymond Toy at 2018-09-22T19:50:40Z Fix #69: Always compile in GC assertion code - - - - - 9cb80666 by Raymond Toy at 2018-09-22T19:50:40Z Merge branch 'issue-69-compile-in-gc-assert' into 'master' Fix #69: Always compile in GC assertion code Closes #69 See merge request cmucl/cmucl!41 - - - - - 925241a9 by Raymond Toy at 2018-09-22T19:57:52Z Fix some typos in comment. - - - - - 08a948e1 by Raymond Toy at 2018-09-22T20:02:05Z Update from commit logs - - - - - 810c52ea by Raymond Toy at 2018-10-07T21:10:41Z Define control_stack_end for all platforms - - - - - f471f66e by Raymond Toy at 2018-10-07T23:51:45Z Update with new docstring - - - - - 741b6176 by Raymond Toy at 2018-10-12T17:16:40Z Update translation files - - - - - b6faace8 by Raymond Toy at 2018-10-12T18:20:56Z Update notes - - - - - 0824e61e by Raymond Toy at 2018-12-06T22:42:16Z Fix #71: More info from machine-type/version on x86 - - - - - 3843a50c by Raymond Toy at 2018-12-06T22:42:16Z Merge branch 'rtoy-issue-71' into 'master' Fix #71: More info from machine-type/version on x86 Closes #71 See merge request cmucl/cmucl!42 - - - - - 6167e353 by Raymond Toy at 2018-12-08T16:58:15Z Update version numbers for 21d. - - - - - b664e46d by Raymond Toy at 2018-12-08T16:58:15Z Merge branch '21d-branch' into 'master' Update version numbers for 21d. See merge request cmucl/cmucl!43 - - - - - cb825da9 by Raymond Toy at 2018-12-10T14:53:27Z Rename BUILDING to BUILDIND.md and convert to markdown Initial conversion of BUILDING to markdown. - - - - - 15655145 by Raymond Toy at 2018-12-10T15:02:13Z Fix some incorrect markdown markup - - - - - d9487768 by Raymond Toy at 2018-12-10T15:55:54Z More markup fixes - - - - - 5e075fa0 by Raymond Toy at 2018-12-17T02:49:54Z Merge branch 'master' into rtoy-update-clx-with-cmucl-fixes - - - - - 30 changed files: - .gitlab-ci.yml - + .gitlab/issue_templates/Bug.md - + .gitlab/issue_templates/Feature.md - BUILDING → BUILDING.md - bin/build.sh - bin/create-target.sh - bin/run-tests.sh - + src/bootfiles/21c/boot-2018-02-1.lisp - + src/bootfiles/21c/boot-21d.lisp - src/clx/package.lisp - src/code/backq.lisp - src/code/bignum.lisp - src/code/exports.lisp - src/code/float-trap.lisp - src/code/float.lisp - src/code/gc.lisp - src/code/rand-xoroshiro.lisp - src/code/run-program.lisp - src/code/x86-vm.lisp - src/compiler/byte-comp.lisp - src/compiler/float-tran.lisp - src/compiler/generic/objdef.lisp - src/contrib/asdf/asdf.lisp - src/contrib/asdf/doc/asdf.html - src/contrib/asdf/doc/asdf.info - src/contrib/asdf/doc/asdf.pdf - src/docs/cmu-user/Makefile - src/docs/cmu-user/aliens.tex - src/docs/cmu-user/cmu-user.hva - src/docs/cmu-user/cmu-user.tex The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/6c18cc63ba3b98ede7c16026… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/6c18cc63ba3b98ede7c16026… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] 3 commits: Import upstream clx version 0.7.5-19-g623c339
by Raymond Toy 17 Dec '18

17 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: 60bde987 by Raymond Toy at 2018-12-16T23:58:32Z Import upstream clx version 0.7.5-19-g623c339 Straight copy of sharplispers/clx commit 623c339 - - - - - 48bc44d6 by Raymond Toy at 2018-12-17T00:00:09Z Merge branch 'upstream-clx' into rtoy-update-clx-with-cmucl-fixes - - - - - 6c18cc63 by Raymond Toy at 2018-12-17T00:45:58Z Compile clx files in the same order as in clx.asd Ran contrib-demos as a test of clx and everything appears to work correctly. - - - - - 3 changed files: - src/clx/depdefs.lisp - src/clx/manual/clx.texinfo - src/tools/clxcom.lisp Changes: ===================================== src/clx/depdefs.lisp ===================================== @@ -387,9 +387,7 @@ ;; FIXME: maybe we should reevaluate this? (defvar *def-clx-class-use-defclass* #+(or Genera allegro) t - #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) - #+(and cmu (not pcl)) nil - #-(or Genera cmu allegro) nil + #-(or Genera allegro) nil "Controls whether DEF-CLX-CLASS uses DEFCLASS. If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of ===================================== src/clx/manual/clx.texinfo ===================================== @@ -15162,11 +15162,11 @@ a keycode. @item Convert the keycode into its corresponding keysym, based on the -current keyboard mapping. See @var{keycode->keysym}. +current keyboard mapping. See @var{keycode->keysym}. @item Convert the keysym into the corresponding Common Lisp character. See -@var{keysym->character}. +@var{keysym->character}. @end enumerate @menu ===================================== src/tools/clxcom.lisp ===================================== @@ -75,9 +75,15 @@ (comf "target:clx/extensions/glx" :load t) (comf "target:clx/extensions/gl" :load t) (comf "target:clx/extensions/dpms" :load t) + (comf "target:clx/extensions/xtest" :load t) (comf "target:clx/extensions/screensaver" :load t) + (comf "target:clx/extensions/randr" :load t) (comf "target:clx/extensions/xinerama" :load t) - (comf "target:clx/extensions/xtest" :load t)) + (comf "target:clx/extensions/dbe" :load t) + (comf "target:clx/extensions/xc-misc" :load t) + (comf "target:clx/extensions/dri2" :load t) + (comf "target:clx/extensions/composite" :load t) + ) (comf "target:code/clx-ext") (comf "target:hemlock/charmacs" :load t) (comf "target:hemlock/key-event" :load t) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/81e08b4c44f842db6e07cf64… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/81e08b4c44f842db6e07cf64… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] 3 commits: Update to upstream version 0.7.5-17-g1f2b6f3
by Raymond Toy 16 Dec '18

16 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: dded48c6 by Raymond Toy at 2018-12-16T17:44:37Z Update to upstream version 0.7.5-17-g1f2b6f3 This is a copy of the upstream version, unchanged. - - - - - 3688d64c by Raymond Toy at 2018-12-16T18:00:42Z Merge branch 'upstream-clx' into rtoy-update-clx-with-cmucl-fixes # Conflicts: # src/clx/dependent.lisp # src/clx/macros.lisp - - - - - 81e08b4c by Raymond Toy at 2018-12-16T18:05:02Z Update extensions with upstream The merge with upstream had conflicts in extensions/shape.lisp and extensions/xrender.lisp and the new files were added as shape.lisp~ upstream-clx and xrender.lisp~upstream-clx. Just copy these files over the existing ones. - - - - - 28 changed files: - src/clx/CHANGES - src/clx/NEWS - src/clx/README-R5 - + src/clx/README.md - + src/clx/ci-doc-gh-pages.sh - src/clx/clx.asd - src/clx/debug/debug.lisp - src/clx/debug/describe.lisp - src/clx/debug/event-test.lisp - src/clx/debug/keytrans.lisp - src/clx/debug/trace.lisp - src/clx/debug/util.lisp - + src/clx/demo/image.lisp - + src/clx/demo/trapezoid.lisp - src/clx/dep-allegro.lisp - src/clx/dep-lispworks.lisp - src/clx/dep-openmcl.lisp - src/clx/dependent.lisp - src/clx/exclMakefile - src/clx/exclREADME - src/clx/excldep.c - + src/clx/extensions/composite.lisp - + src/clx/extensions/dbe.lisp - + src/clx/extensions/dri2.lisp - + src/clx/extensions/randr.lisp - src/clx/extensions/shape.lisp - + src/clx/extensions/xc-misc.lisp - src/clx/extensions/xrender.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d10aa4a6e7edcf8e6254cb88… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d10aa4a6e7edcf8e6254cb88… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][upstream-clx] Import upstream clx version 0.7.5-19-g623c339
by Raymond Toy 16 Dec '18

16 Dec '18

Raymond Toy pushed to branch upstream-clx at cmucl / cmucl Commits: 60bde987 by Raymond Toy at 2018-12-16T23:58:32Z Import upstream clx version 0.7.5-19-g623c339 Straight copy of sharplispers/clx commit 623c339 - - - - - 4 changed files: - src/clx/README-CMUCL - src/clx/depdefs.lisp - src/clx/dependent.lisp - src/clx/manual/clx.texinfo Changes: ===================================== src/clx/README-CMUCL ===================================== @@ -1,40 +1,9 @@ -$Id: README-CMUCL,v 1.2 2009/06/11 16:03:56 rtoy Rel $ +This is an import of Telent-CLX from the fork +https://github.com/sharplispers/clx, version +6e39a0df2a0a1d083166f405d4b8bbc463d54d85. -This is an import of Telent-CLX as of 0.7.3. +All (almost?) files are included. A few changes to fix bugs related +to CMUCL have been added, as well as the CVS id. I've tried to make +few changes so it will be easy to merge again when desired. -All files are included. A few changes to fix bugs related to CMUCL -have been added, as well as the CVS id. I've tried to make few -changes so it will be easy to merge again when desired. - -The following files from this directory are compiled and loaded by -CMUCL when it builds utilities: - -clx-library.lisp -package.lisp -depdefs.lisp -clx.lisp -dependent.lisp -macros.lisp -bufmac.lisp -buffer.lisp -display.lisp -gcontext.lisp -input.lisp -requests.lisp -fonts.lisp -graphics.lisp -text.lisp -attributes.lisp -translate.lisp -keysyms.lisp -manager.lisp -image.lisp -resource.lisp -shape.lisp -big-requests.lisp -xvidmode.lisp -xrender.lisp -glx.lisp -gl.lisp -dpms.lisp -provide.lisp +See src/tools/clxcom.lisp to see what files are compiled. ===================================== src/clx/depdefs.lisp ===================================== @@ -387,9 +387,7 @@ ;; FIXME: maybe we should reevaluate this? (defvar *def-clx-class-use-defclass* #+(or Genera allegro) t - #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) - #+(and cmu (not pcl)) nil - #-(or Genera cmu allegro) nil + #-(or Genera allegro) nil "Controls whether DEF-CLX-CLASS uses DEFCLASS. If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of ===================================== src/clx/dependent.lisp ===================================== @@ -884,6 +884,47 @@ :element-type '(unsigned-byte 8) :input t :output t :buffering :none)) +#+cmu +(defun open-x-stream (host display protocol) + (let ((stream-fd + (ecase protocol + ;; establish a TCP connection to the X11 server, which is + ;; listening on port 6000 + display-number + ((:internet :tcp nil) + (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display)))) + (unless (plusp fd) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Cannot connect to internet socket: ~S" + (unix:get-unix-error-msg)))) + fd)) + ;; establish a connection to the X11 server over a Unix + ;; socket. (:|| comes from Darwin's weird DISPLAY + ;; environment variable) + ((:unix :local :||) + (let ((path (unix-socket-path-from-host host display))) + (unless (probe-file path) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Unix socket ~s does not exist" path))) + (let ((fd (ext:connect-to-unix-socket (namestring path)))) + (unless (plusp fd) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Can't connect to unix socket: ~S" + (unix:get-unix-error-msg)))) + fd)))))) + (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8)))) + ;;; BUFFER-READ-DEFAULT for CMU Common Lisp. ;;; ;;; If timeout is 0, then we call LISTEN to see if there is any input. @@ -1643,7 +1684,7 @@ Returns a list of (host display-number screen protocol)." (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) - `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data + `(#+cmu lisp::with-array-data #+sbcl sb-kernel:with-array-data ((,variable ,pixarray) (start) (end)) (declare (ignore start end)) ,@body)) @@ -1762,11 +1803,11 @@ Returns a list of (host display-number screen protocol)." height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) - (kernel::with-array-data ((sdata source) + (lisp::with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) - (kernel::with-array-data ((ddata dest) + (lisp::with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) ===================================== src/clx/manual/clx.texinfo ===================================== @@ -15162,11 +15162,11 @@ a keycode. @item Convert the keycode into its corresponding keysym, based on the -current keyboard mapping. See @var{keycode->keysym}. +current keyboard mapping. See @var{keycode->keysym}. @item Convert the keysym into the corresponding Common Lisp character. See -@var{keysym->character}. +@var{keysym->character}. @end enumerate @menu View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/60bde987869e73a25475727ac… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/60bde987869e73a25475727ac… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][upstream-clx] Update to upstream version 0.7.5-17-g1f2b6f3
by Raymond Toy 16 Dec '18

16 Dec '18

Raymond Toy pushed to branch upstream-clx at cmucl / cmucl Commits: dded48c6 by Raymond Toy at 2018-12-16T17:44:37Z Update to upstream version 0.7.5-17-g1f2b6f3 This is a copy of the upstream version, unchanged. - - - - - 30 changed files: - src/clx/CHANGES - src/clx/NEWS - src/clx/README-R5 - + src/clx/README.md - + src/clx/ci-doc-gh-pages.sh - src/clx/clx.asd - src/clx/debug/debug.lisp - src/clx/debug/describe.lisp - src/clx/debug/event-test.lisp - src/clx/debug/keytrans.lisp - src/clx/debug/trace.lisp - src/clx/debug/util.lisp - src/clx/demo/bezier.lisp - src/clx/demo/beziertest.lisp - src/clx/demo/clclock.lisp - src/clx/demo/clipboard.lisp - src/clx/demo/clx-demos.lisp - src/clx/demo/gl-test.lisp - src/clx/demo/hello.lisp - + src/clx/demo/image.lisp - src/clx/demo/mandel.lisp - + src/clx/demo/trapezoid.lisp - src/clx/dep-allegro.lisp - src/clx/dep-lispworks.lisp - src/clx/dep-openmcl.lisp - src/clx/dependent.lisp - src/clx/exclMakefile - src/clx/exclREADME - src/clx/excldep.c - + src/clx/extensions/big-requests.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/dded48c6a9b7cd7a3f5ac066f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/dded48c6a9b7cd7a3f5ac066f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0